KIDS Distribution saved on Jun 26, 2009@16:24:02 VERSION 6 - BETA RELEASE **KIDS**:MSC GTM INTEGRATION*1.0*6^ **INSTALL NAME** MSC GTM INTEGRATION*1.0*6 "BLD",7026,0) MSC GTM INTEGRATION*1.0*6^^0^3090626^y "BLD",7026,1,0) ^^1^1^3090611^ "BLD",7026,1,1,0) SYSTEM STATUS AND JOBEXAM FOR GT.M "BLD",7026,4,0) ^9.64PA^^ "BLD",7026,6.3) 43 "BLD",7026,"INIT") "BLD",7026,"KRN",0) ^9.67PA^8989.52^19 "BLD",7026,"KRN",.4,0) .4 "BLD",7026,"KRN",.401,0) .401 "BLD",7026,"KRN",.402,0) .402 "BLD",7026,"KRN",.403,0) .403 "BLD",7026,"KRN",.403,"NM",0) ^9.68A^2^2 "BLD",7026,"KRN",.403,"NM",1,0) MSCZJOBEXAM FILE #3.081^3.081^0 "BLD",7026,"KRN",.403,"NM",2,0) MSCZLOCK FILE #3.081^3.081^0 "BLD",7026,"KRN",.403,"NM","B","MSCZJOBEXAM FILE #3.081",1) "BLD",7026,"KRN",.403,"NM","B","MSCZLOCK FILE #3.081",2) "BLD",7026,"KRN",.5,0) .5 "BLD",7026,"KRN",.84,0) .84 "BLD",7026,"KRN",3.6,0) 3.6 "BLD",7026,"KRN",3.8,0) 3.8 "BLD",7026,"KRN",9.2,0) 9.2 "BLD",7026,"KRN",9.2,"NM",0) ^9.68A^^ "BLD",7026,"KRN",9.8,0) 9.8 "BLD",7026,"KRN",9.8,"NM",0) ^9.68A^49^41 "BLD",7026,"KRN",9.8,"NM",1,0) MSCZJOB^^0^B12928863 "BLD",7026,"KRN",9.8,"NM",4,0) MSCZJOBU^^0^B7613711 "BLD",7026,"KRN",9.8,"NM",5,0) ZIS4GTM^^0^B18512871 "BLD",7026,"KRN",9.8,"NM",7,0) XTER1A^^0^B29100251 "BLD",7026,"KRN",9.8,"NM",8,0) ZUGTM^^0^B10012519 "BLD",7026,"KRN",9.8,"NM",11,0) ZCD^^0^B21703984 "BLD",7026,"KRN",9.8,"NM",13,0) ZOSV2GTM^^0^B6700455 "BLD",7026,"KRN",9.8,"NM",14,0) ZOSFGUX^^0^B22080506 "BLD",7026,"KRN",9.8,"NM",15,0) ZISHGUX^^0^B36911880 "BLD",7026,"KRN",9.8,"NM",16,0) HLCSTCP1^^0^B29662559 "BLD",7026,"KRN",9.8,"NM",17,0) HLCSTCP^^0^B32434118 "BLD",7026,"KRN",9.8,"NM",18,0) HLCSLNCH^^0^B37355917 "BLD",7026,"KRN",9.8,"NM",19,0) XOBVLL^^0^B18012967 "BLD",7026,"KRN",9.8,"NM",20,0) XOBVRH^^0^B13028891 "BLD",7026,"KRN",9.8,"NM",21,0) XOBVSKT^^0^B19755798 "BLD",7026,"KRN",9.8,"NM",22,0) XOBVTCPL^^0^B13492271 "BLD",7026,"KRN",9.8,"NM",23,0) XWBTCPM^^0^B56922128 "BLD",7026,"KRN",9.8,"NM",24,0) ZTMGRSET^^0^B54537333 "BLD",7026,"KRN",9.8,"NM",25,0) ZISTCPS^^0^B18299533 "BLD",7026,"KRN",9.8,"NM",26,0) XPDR^^0^B52133395 "BLD",7026,"KRN",9.8,"NM",27,0) ZISFGUX^^1^ "BLD",7026,"KRN",9.8,"NM",28,0) ZTER^^0^B39678986 "BLD",7026,"KRN",9.8,"NM",29,0) ZSTARTGUX^^0^B140233 "BLD",7026,"KRN",9.8,"NM",31,0) MSCXUS3A^^0^B8005003 "BLD",7026,"KRN",9.8,"NM",32,0) RORHL7A^^0^B35660209 "BLD",7026,"KRN",9.8,"NM",33,0) ZOSVGUX^^0^B1197142 "BLD",7026,"KRN",9.8,"NM",34,0) DGMSTAPI^^0^B48539163 "BLD",7026,"KRN",9.8,"NM",35,0) GMRCA2^^0^B10634 "BLD",7026,"KRN",9.8,"NM",36,0) MAGDMEDL^^0^B3132920 "BLD",7026,"KRN",9.8,"NM",37,0) PRCSEA^^0^B66865498 "BLD",7026,"KRN",9.8,"NM",38,0) PSBOMH1^^0^B71152392 "BLD",7026,"KRN",9.8,"NM",39,0) PSBRPC2^^0^B44967923 "BLD",7026,"KRN",9.8,"NM",40,0) PXRMTMED^^0^B9970277 "BLD",7026,"KRN",9.8,"NM",41,0) VALMW3^^0^B21033865 "BLD",7026,"KRN",9.8,"NM",42,0) XQALSUR1^^0^B29675685 "BLD",7026,"KRN",9.8,"NM",43,0) XUMF5AU^^0^B76801793 "BLD",7026,"KRN",9.8,"NM",44,0) ZSTOPGUX^^0^B148072 "BLD",7026,"KRN",9.8,"NM",46,0) MSCZJOBS^^0^B3805853 "BLD",7026,"KRN",9.8,"NM",47,0) ZOSVONT^^0^B23474671 "BLD",7026,"KRN",9.8,"NM",48,0) ZISFGTM^^0^B9317180 "BLD",7026,"KRN",9.8,"NM",49,0) ZSSGUX^^0^B47435 "BLD",7026,"KRN",9.8,"NM","B","DGMSTAPI",34) "BLD",7026,"KRN",9.8,"NM","B","GMRCA2",35) "BLD",7026,"KRN",9.8,"NM","B","HLCSLNCH",18) "BLD",7026,"KRN",9.8,"NM","B","HLCSTCP",17) "BLD",7026,"KRN",9.8,"NM","B","HLCSTCP1",16) "BLD",7026,"KRN",9.8,"NM","B","MAGDMEDL",36) "BLD",7026,"KRN",9.8,"NM","B","MSCXUS3A",31) "BLD",7026,"KRN",9.8,"NM","B","MSCZJOB",1) "BLD",7026,"KRN",9.8,"NM","B","MSCZJOBS",46) "BLD",7026,"KRN",9.8,"NM","B","MSCZJOBU",4) "BLD",7026,"KRN",9.8,"NM","B","PRCSEA",37) "BLD",7026,"KRN",9.8,"NM","B","PSBOMH1",38) "BLD",7026,"KRN",9.8,"NM","B","PSBRPC2",39) "BLD",7026,"KRN",9.8,"NM","B","PXRMTMED",40) "BLD",7026,"KRN",9.8,"NM","B","RORHL7A",32) "BLD",7026,"KRN",9.8,"NM","B","VALMW3",41) "BLD",7026,"KRN",9.8,"NM","B","XOBVLL",19) "BLD",7026,"KRN",9.8,"NM","B","XOBVRH",20) "BLD",7026,"KRN",9.8,"NM","B","XOBVSKT",21) "BLD",7026,"KRN",9.8,"NM","B","XOBVTCPL",22) "BLD",7026,"KRN",9.8,"NM","B","XPDR",26) "BLD",7026,"KRN",9.8,"NM","B","XQALSUR1",42) "BLD",7026,"KRN",9.8,"NM","B","XTER1A",7) "BLD",7026,"KRN",9.8,"NM","B","XUMF5AU",43) "BLD",7026,"KRN",9.8,"NM","B","XWBTCPM",23) "BLD",7026,"KRN",9.8,"NM","B","ZCD",11) "BLD",7026,"KRN",9.8,"NM","B","ZIS4GTM",5) "BLD",7026,"KRN",9.8,"NM","B","ZISFGTM",48) "BLD",7026,"KRN",9.8,"NM","B","ZISFGUX",27) "BLD",7026,"KRN",9.8,"NM","B","ZISHGUX",15) "BLD",7026,"KRN",9.8,"NM","B","ZISTCPS",25) "BLD",7026,"KRN",9.8,"NM","B","ZOSFGUX",14) "BLD",7026,"KRN",9.8,"NM","B","ZOSV2GTM",13) "BLD",7026,"KRN",9.8,"NM","B","ZOSVGUX",33) "BLD",7026,"KRN",9.8,"NM","B","ZOSVONT",47) "BLD",7026,"KRN",9.8,"NM","B","ZSSGUX",49) "BLD",7026,"KRN",9.8,"NM","B","ZSTARTGUX",29) "BLD",7026,"KRN",9.8,"NM","B","ZSTOPGUX",44) "BLD",7026,"KRN",9.8,"NM","B","ZTER",28) "BLD",7026,"KRN",9.8,"NM","B","ZTMGRSET",24) "BLD",7026,"KRN",9.8,"NM","B","ZUGTM",8) "BLD",7026,"KRN",19,0) 19 "BLD",7026,"KRN",19,"NM",0) ^9.68A^2^2 "BLD",7026,"KRN",19,"NM",1,0) MSCZJOB^^0 "BLD",7026,"KRN",19,"NM",2,0) MSCZLOCK^^0 "BLD",7026,"KRN",19,"NM","B","MSCZJOB",1) "BLD",7026,"KRN",19,"NM","B","MSCZLOCK",2) "BLD",7026,"KRN",19.1,0) 19.1 "BLD",7026,"KRN",101,0) 101 "BLD",7026,"KRN",409.61,0) 409.61 "BLD",7026,"KRN",771,0) 771 "BLD",7026,"KRN",870,0) 870 "BLD",7026,"KRN",8989.51,0) 8989.51 "BLD",7026,"KRN",8989.52,0) 8989.52 "BLD",7026,"KRN",8994,0) 8994 "BLD",7026,"KRN","B",.4,.4) "BLD",7026,"KRN","B",.401,.401) "BLD",7026,"KRN","B",.402,.402) "BLD",7026,"KRN","B",.403,.403) "BLD",7026,"KRN","B",.5,.5) "BLD",7026,"KRN","B",.84,.84) "BLD",7026,"KRN","B",3.6,3.6) "BLD",7026,"KRN","B",3.8,3.8) "BLD",7026,"KRN","B",9.2,9.2) "BLD",7026,"KRN","B",9.8,9.8) "BLD",7026,"KRN","B",19,19) "BLD",7026,"KRN","B",19.1,19.1) "BLD",7026,"KRN","B",101,101) "BLD",7026,"KRN","B",409.61,409.61) "BLD",7026,"KRN","B",771,771) "BLD",7026,"KRN","B",870,870) "BLD",7026,"KRN","B",8989.51,8989.51) "BLD",7026,"KRN","B",8989.52,8989.52) "BLD",7026,"KRN","B",8994,8994) "BLD",7026,"MSC") /home/jon/MSC_GTM_INTEG_6.KID "BLD",7026,"MSCOM") VERSION 6 - BETA RELEASE "BLD",7026,"PRE") MSCGUX53 "BLD",7026,"QUES",0) ^9.62^^ "KRN",.403,121,-1) 0^1 "KRN",.403,121,0) MSCZJOBEXAM^ ^@^^3070530.1755^^^3.081^0^1^1 "KRN",.403,121,12) "KRN",.403,121,21) "KRN",.403,121,40,0) ^.4031I^3^3 "KRN",.403,121,40,1,0) 1^^1,1^^^1^17,80 "KRN",.403,121,40,1,1) Page 1 "KRN",.403,121,40,1,40,0) ^.4032IP^433^2 "KRN",.403,121,40,1,40,432,0) MSCZJOBEXAM^4^3,2^e "KRN",.403,121,40,1,40,432,2) 13^^u^^1 "KRN",.403,121,40,1,40,432,"COMP MUL") D COMPMUL^MSCZJOB "KRN",.403,121,40,1,40,432,"COMP MUL PTR") "KRN",.403,121,40,1,40,433,0) MSCZJOBEXAM HDR^1^1,2^d "KRN",.403,121,40,2,0) 2^^1,1^^^1^18,79 "KRN",.403,121,40,2,1) Page 2 "KRN",.403,121,40,2,40,0) ^.4032IP^437^3 "KRN",.403,121,40,2,40,434,0) MSCZJOBEXAM 2^1^1,1^e "KRN",.403,121,40,2,40,435,0) MSCZJOBVARS^3^8,3^e "KRN",.403,121,40,2,40,435,2) 9^^f^^1 "KRN",.403,121,40,2,40,435,"COMP MUL") D COMPVARS^MSCZJOB "KRN",.403,121,40,2,40,437,0) MSCZJOBSTACK^4^3,3^e "KRN",.403,121,40,2,40,437,2) 3^ "KRN",.403,121,40,2,40,437,"COMP MUL") D COMPSTK^MSCZJOB "KRN",.403,121,40,3,0) 3^^4,4^^^1^15,70 "KRN",.403,121,40,3,1) Page 3 "KRN",.403,121,40,3,40,0) ^.4032IP^436^1 "KRN",.403,121,40,3,40,436,0) MSCZJOBLOCKS^1^2,3^e "KRN",.403,121,40,3,40,436,2) 6^ "KRN",.403,121,40,3,40,436,"COMP MUL") D COMPLKS^MSCZJOB "KRN",.403,121,21400) 1 "KRN",.403,122,-1) 0^2 "KRN",.403,122,0) MSCZLOCK^ ^@^^3070530.1755^^^3.081^0^1^1 "KRN",.403,122,40,0) ^.4031I^1^1 "KRN",.403,122,40,1,0) 1^^1,1^^^0^17,80 "KRN",.403,122,40,1,1) Page 1 "KRN",.403,122,40,1,40,0) ^.4032IP^439^2 "KRN",.403,122,40,1,40,438,0) MSCZLOCKEXAM^4^3,2^e "KRN",.403,122,40,1,40,438,2) 13^^u^^1 "KRN",.403,122,40,1,40,438,"COMP MUL") D COMPLK^MSCZJOB "KRN",.403,122,40,1,40,439,0) MSCZJOBLOCK HDR^1^1,1^d "KRN",.404,432,0) MSCZJOBEXAM^3.081 "KRN",.404,432,40,0) ^.4044I^5^5 "KRN",.404,432,40,1,0) 1^^2^^JOB NUMBER "KRN",.404,432,40,1,2) 1,2^6 "KRN",.404,432,40,1,3) !M "KRN",.404,432,40,1,3.1) S Y=$$JOB^MSCZJOB(D0) S:Y=$J Y=Y_"*" "KRN",.404,432,40,1,4) ^^^2 "KRN",.404,432,40,1,10) S DDSSTACK=2,MSCJOBD0=D0,MSCJOBID=$P(MSCZJOB(D0),U) "KRN",.404,432,40,1,20) F "KRN",.404,432,40,2,0) 2^^2^^DEVICE "KRN",.404,432,40,2,2) 1,9^23 "KRN",.404,432,40,2,3) !M "KRN",.404,432,40,2,3.1) S Y=$$DEV^MSCZJOB(D0) "KRN",.404,432,40,2,4) ^^^1 "KRN",.404,432,40,2,20) F "KRN",.404,432,40,3,0) 4^^2^^NAMESPACE "KRN",.404,432,40,3,2) 1,48^11 "KRN",.404,432,40,3,3) !M "KRN",.404,432,40,3,3.1) S Y=$$NSP^MSCZJOB(D0) "KRN",.404,432,40,3,4) ^^^1 "KRN",.404,432,40,3,20) F "KRN",.404,432,40,4,0) 5^^2^^ROUTINE "KRN",.404,432,40,4,2) 1,60^18 "KRN",.404,432,40,4,3) !M "KRN",.404,432,40,4,3.1) S Y=$$ROUTINE^MSCZJOB(D0) "KRN",.404,432,40,4,4) ^^^1 "KRN",.404,432,40,4,20) F^U "KRN",.404,432,40,5,0) 3^^2^^USER "KRN",.404,432,40,5,2) 1,33^14 "KRN",.404,432,40,5,3) !M "KRN",.404,432,40,5,3.1) S Y=$$USER^MSCZJOB(D0) "KRN",.404,432,40,5,4) ^^^1 "KRN",.404,432,40,5,20) F "KRN",.404,433,0) MSCZJOBEXAM HDR^3.081^ "KRN",.404,433,40,0) ^.4044I^2^2 "KRN",.404,433,40,1,0) 1^Process Device User Namespace Routine ^1 "KRN",.404,433,40,1,2) ^^2,1 "KRN",.404,433,40,2,0) 2^!M^1 "KRN",.404,433,40,2,.1) S Y=$$GET1^DIQ(8989.3,1,.01) "KRN",.404,433,40,2,2) ^^1,28 "KRN",.404,434,0) MSCZJOBEXAM 2^3.081 "KRN",.404,434,40,0) ^.4044I^7^7 "KRN",.404,434,40,1,0) 1^Job^2^^JOB NUMBER "KRN",.404,434,40,1,2) 2,8^6^2,3 "KRN",.404,434,40,1,3) !M "KRN",.404,434,40,1,3.1) S Y=$$JOB^MSCZJOB(MSCJOBD0) "KRN",.404,434,40,1,20) N "KRN",.404,434,40,2,0) 2^NSpace^2^^NAMESPACE "KRN",.404,434,40,2,2) 2,24^11^2,16 "KRN",.404,434,40,2,3) !M "KRN",.404,434,40,2,3.1) S Y=$$NSP^MSCZJOB(MSCJOBD0) "KRN",.404,434,40,2,4) ^^^2 "KRN",.404,434,40,2,20) F "KRN",.404,434,40,3,0) 3^Routine^2 "KRN",.404,434,40,3,2) 2,46^16^2,37 "KRN",.404,434,40,3,3) !M "KRN",.404,434,40,3,3.1) S Y=$$ROUTINE^MSCZJOB(MSCJOBD0) "KRN",.404,434,40,3,4) ^^^2 "KRN",.404,434,40,3,20) F^U "KRN",.404,434,40,4,0) 4^^2^^USER "KRN",.404,434,40,4,2) 2,63^14 "KRN",.404,434,40,4,3) !M "KRN",.404,434,40,4,3.1) S Y=$$USER^MSCZJOB(MSCJOBD0) "KRN",.404,434,40,4,4) ^^^2 "KRN",.404,434,40,4,20) F "KRN",.404,434,40,5,0) 5^Device^2^^DEVICE "KRN",.404,434,40,5,2) 3,24^38^3,16 "KRN",.404,434,40,5,3) !M "KRN",.404,434,40,5,3.1) S Y=$$DEV^MSCZJOB(MSCJOBD0) "KRN",.404,434,40,5,4) ^^^1 "KRN",.404,434,40,5,20) F^U "KRN",.404,434,40,6,0) 4.4^LOCKs^2^^LOCKS "KRN",.404,434,40,6,2) 3,10^3^3,3 "KRN",.404,434,40,6,3) !M "KRN",.404,434,40,6,3.1) S Y=$$LOCKS^MSCZJOB "KRN",.404,434,40,6,10) S DDSSTACK=3 "KRN",.404,434,40,6,20) N "KRN",.404,434,40,7,0) 6^KILL JOB?^2^^KILL "KRN",.404,434,40,7,2) 3,74^3^3,63 "KRN",.404,434,40,7,13) N X,Y I DDSEXT="YES" D KILL^MSCZJOB(MSCJOBID) "KRN",.404,434,40,7,20) Y "KRN",.404,435,0) MSCZJOBVARS^3.081 "KRN",.404,435,40,0) ^.4044I^3^3 "KRN",.404,435,40,1,0) 1^^2^^VARIABLE NAME "KRN",.404,435,40,1,2) 1,1^24 "KRN",.404,435,40,1,3) !M "KRN",.404,435,40,1,3.1) S Y=$P(@MSC@(MSCJOBID,"V",D0),"=") "KRN",.404,435,40,1,4) ^^^2 "KRN",.404,435,40,1,20) F "KRN",.404,435,40,2,0) 2^^2^^VALUE OF VARIABLE "KRN",.404,435,40,2,2) 1,28^48 "KRN",.404,435,40,2,3) !M "KRN",.404,435,40,2,3.1) S Y=$P(@MSC@(MSCJOBID,"V",D0),"=",2,999) "KRN",.404,435,40,2,4) ^^^2 "KRN",.404,435,40,2,20) F^U "KRN",.404,435,40,3,0) 1.5^=^1 "KRN",.404,435,40,3,2) ^^1,26 "KRN",.404,436,0) MSCZJOBLOCKS^3.081^ "KRN",.404,436,40,0) ^.4044I^2^2 "KRN",.404,436,40,1,0) 1^^2^^LOCKS "KRN",.404,436,40,1,2) 2,1^47 "KRN",.404,436,40,1,3) !M "KRN",.404,436,40,1,3.1) S Y=@MSC@(MSCJOBID,"L",D0) "KRN",.404,436,40,1,4) ^^^2 "KRN",.404,436,40,1,20) F^U "KRN",.404,436,40,2,0) 2^UNLOCK?^2^^UNLOCK "KRN",.404,436,40,2,2) 2,58^3^2,49^1 "KRN",.404,436,40,2,13) I DDSEXT="YES" D UNLOCK^MSCZJOB(D0) "KRN",.404,436,40,2,20) Y "KRN",.404,437,0) MSCZJOBSTACK^3.081 "KRN",.404,437,40,0) ^.4044I^1^1 "KRN",.404,437,40,1,0) 1^^2^^STACK "KRN",.404,437,40,1,2) 2,1^75 "KRN",.404,437,40,1,3) !M "KRN",.404,437,40,1,3.1) S Y=$$STACK^MSCZJOB(D0) "KRN",.404,437,40,1,4) ^^^2 "KRN",.404,437,40,1,20) F^U "KRN",.404,438,0) MSCZLOCKEXAM^3.081 "KRN",.404,438,40,0) ^.4044I^5^5 "KRN",.404,438,40,1,0) 1^^2^^JOB NUMBER "KRN",.404,438,40,1,2) 1,2^6 "KRN",.404,438,40,1,3) !M "KRN",.404,438,40,1,3.1) S Y=$P($G(MSCZLK(D0)),U,5) S:Y=$J Y=Y_"*" "KRN",.404,438,40,1,4) ^^^2 "KRN",.404,438,40,1,10) S DDSSTACK=2,MSCJOBD0=D0,MSCJOBID=$P(MSCZJOB(D0),U) "KRN",.404,438,40,1,20) F "KRN",.404,438,40,2,0) 2^^2^^LOCK "KRN",.404,438,40,2,2) 1,9^23 "KRN",.404,438,40,2,3) !M "KRN",.404,438,40,2,3.1) S Y=$TR($P($G(MSCZLK(D0)),U),"~") "KRN",.404,438,40,2,4) ^^^1 "KRN",.404,438,40,2,20) F "KRN",.404,438,40,3,0) 4^^2^^ROUTINE "KRN",.404,438,40,3,2) 1,48^25 "KRN",.404,438,40,3,3) !M "KRN",.404,438,40,3,3.1) S Y=$TR($P($G(MSCZLK(D0)),U,3),$C(126),U) "KRN",.404,438,40,3,4) ^^^1 "KRN",.404,438,40,3,20) F^U "KRN",.404,438,40,4,0) 5^^2^^UNLOCK "KRN",.404,438,40,4,2) 1,76^3 "KRN",.404,438,40,4,3) !M "KRN",.404,438,40,4,4) ^^^0 "KRN",.404,438,40,4,13) I DDSEXT="YES" D UNL^MSCZJOB(D0) "KRN",.404,438,40,4,20) Y^U "KRN",.404,438,40,5,0) 3^^2^^USER "KRN",.404,438,40,5,2) 1,33^14 "KRN",.404,438,40,5,3) !M "KRN",.404,438,40,5,3.1) S Y=$P($G(MSCZLK(D0)),U,2) "KRN",.404,438,40,5,4) ^^^1 "KRN",.404,438,40,5,20) F "KRN",.404,439,0) MSCZJOBLOCK HDR^3.081 "KRN",.404,439,40,0) ^.4044I^2^2 "KRN",.404,439,40,1,0) 1^Process Lock User Routine Unlock^1 "KRN",.404,439,40,1,2) ^^2,1 "KRN",.404,439,40,2,0) 2^!M^1 "KRN",.404,439,40,2,.1) S Y=$$GET1^DIQ(8989.3,1,.01) "KRN",.404,439,40,2,2) ^^1,28 "KRN",19,14339,-1) 0^1 "KRN",19,14339,0) MSCZJOB^JOB EXAMINE^^R^^^^^^^^ "KRN",19,14339,1,0) ^^1^1^3070623^ "KRN",19,14339,1,1,0) DESIGNED FOR GT.M "KRN",19,14339,25) MSCZJOB "KRN",19,14339,"U") JOB EXAMINE "KRN",19,14340,-1) 0^2 "KRN",19,14340,0) MSCZLOCK^LOCK EXAMINE^^R^^^^^^^^ "KRN",19,14340,1,0) ^^1^1^3070623^ "KRN",19,14340,1,1,0) DESIGNED FOR GT.M "KRN",19,14340,25) LOCK^MSCZJOB "KRN",19,14340,"U") LOCK EXAMINE "MBREQ") 0 "ORD",0,9.8) 9.8;;1;RTNF^XPDTA;RTNE^XPDTA "ORD",0,9.8,0) ROUTINE "ORD",8,.403) .403;8;;;EDEOUT^DIFROMSO(.403,DA,"",XPDA);FPRE^DIFROMSI(.403,"",XPDA);EPRE^DIFROMSI(.403,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.403,DA,"",XPDA);DEL^DIFROMSK(.403,"",%) "ORD",8,.403,0) FORM "ORD",18,19) 19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA "ORD",18,19,0) OPTION "PRE") MSCGUX53 "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 42 "RTN","DGMSTAPI") 0^34^B48539163 "RTN","DGMSTAPI",1,0) DGMSTAPI ;ALB/SCK,MSC/JDA - API's for Military Sexual Trauma ;29APR2009 "RTN","DGMSTAPI",2,0) ;;5.3;Registration;**195,243,308,353,379,443,700,JDA**;Aug 13, 1993 "RTN","DGMSTAPI",3,0) Q "RTN","DGMSTAPI",4,0) ; "RTN","DGMSTAPI",5,0) GETSTAT(DFN,DGDATE) ; Retrieves the current MST status for a patient "RTN","DGMSTAPI",6,0) ; "RTN","DGMSTAPI",7,0) ; Input "RTN","DGMSTAPI",8,0) ; DFN - IEN of patient in the PATIENT File (#2) "RTN","DGMSTAPI",9,0) ; DGDATE - Date for status lookup [OPTIONAL] "RTN","DGMSTAPI",10,0) ; "RTN","DGMSTAPI",11,0) ; Output "RTN","DGMSTAPI",12,0) ; DGMST - Format will depend on result of lookup "RTN","DGMSTAPI",13,0) ; "RTN","DGMSTAPI",14,0) ; If an entry is found then: "RTN","DGMSTAPI",15,0) ; DGMST returns a 7 piece data string, caret(^)-delimited: "RTN","DGMSTAPI",16,0) ; $P(1) = IEN of entry in MST HISTORY File (#29.11) "RTN","DGMSTAPI",17,0) ; $P(2) = Internal value of MST Status ("Y,N,D,U") "RTN","DGMSTAPI",18,0) ; $P(3) = Date of status change "RTN","DGMSTAPI",19,0) ; $P(4) = IEN of provider making determination, file (#200) "RTN","DGMSTAPI",20,0) ; $P(5) = IEN of user who entered status, file (#200) "RTN","DGMSTAPI",21,0) ; $P(6) = External format of MST Status "RTN","DGMSTAPI",22,0) ; $P(7) = IEN pointer of the INSTITUTION file (#4) "RTN","DGMSTAPI",23,0) ; "RTN","DGMSTAPI",24,0) ; If no MST History is found, then: "RTN","DGMSTAPI",25,0) ; DGMST = 0^U "RTN","DGMSTAPI",26,0) ; "U" = (Unknown) "RTN","DGMSTAPI",27,0) ; If an error occured in the GETS^DIQ lookup, then: "RTN","DGMSTAPI",28,0) ; DGMST = -1^^Error Code IEN "RTN","DGMSTAPI",29,0) ; (returned by GETS^DIQ call) "RTN","DGMSTAPI",30,0) ; "RTN","DGMSTAPI",31,0) ; Get most recent MST status entry for the patient from file using "RTN","DGMSTAPI",32,0) ; reverse $Order on the "APDT" x-ref. "RTN","DGMSTAPI",33,0) ; "RTN","DGMSTAPI",34,0) N DGMST,DGIEN,DGFDA,DGMSG "RTN","DGMSTAPI",35,0) S DFN=$G(DFN) "RTN","DGMSTAPI",36,0) I '+DFN!('$D(^DPT(DFN,0))) D G STATQ "RTN","DGMSTAPI",37,0) . S DGMST="-1" "RTN","DGMSTAPI",38,0) I '$D(^DGMS(29.11,"APDT",DFN)) D G STATQ "RTN","DGMSTAPI",39,0) .S DGMST="0^U" "RTN","DGMSTAPI",40,0) S DGDATE=$S(+$G(DGDATE)>0:DGDATE,1:$$NOW^XLFDT) "RTN","DGMSTAPI",41,0) I '$D(^DGMS(29.11,"APDT",DFN,DGDATE)) S DGDATE=$$DATE(DFN,DGDATE) "RTN","DGMSTAPI",42,0) I '+DGDATE D G STATQ "RTN","DGMSTAPI",43,0) . S DGMST="0^U" "RTN","DGMSTAPI",44,0) S DGIEN="" "RTN","DGMSTAPI",45,0) S DGIEN=+$O(^DGMS(29.11,"APDT",DFN,DGDATE,DGIEN),-1) "RTN","DGMSTAPI",46,0) ; "RTN","DGMSTAPI",47,0) ; Check for valid ien, if entry missing, return Unknown "RTN","DGMSTAPI",48,0) I +DGIEN'>0 D G STATQ "RTN","DGMSTAPI",49,0) . S DGMST="0^U" "RTN","DGMSTAPI",50,0) ; "RTN","DGMSTAPI",51,0) ; Retrieve data "RTN","DGMSTAPI",52,0) D GETS^DIQ(29.11,+DGIEN_",","*","IE","DGFDA","DGMSG") "RTN","DGMSTAPI",53,0) ; check for errors "RTN","DGMSTAPI",54,0) I $D(DGMSG) D G STATQ "RTN","DGMSTAPI",55,0) .S DGMST="-1^^"_$G(DGMSG("DIERR",1)) "RTN","DGMSTAPI",56,0) ; "RTN","DGMSTAPI",57,0) S DGMST=DGIEN_U_$G(DGFDA(29.11,+DGIEN_",",3,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",.01,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",4,"I"))_U_$G(DGFDA(29.11,+DGIEN_",",5,"I")) "RTN","DGMSTAPI",58,0) S DGMST=DGMST_U_$G(DGFDA(29.11,+DGIEN_",",3,"E")) "RTN","DGMSTAPI",59,0) S DGMST=DGMST_U_$S($G(DGFDA(29.11,+DGIEN_",",6,"I"))]"":$G(DGFDA(29.11,+DGIEN_",",6,"I")),1:$$SITE) "RTN","DGMSTAPI",60,0) ; "RTN","DGMSTAPI",61,0) STATQ Q $G(DGMST) "RTN","DGMSTAPI",62,0) ; "RTN","DGMSTAPI",63,0) NEWSTAT(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,DGXMIT) ; MST HISTORY (#29.11) filer "RTN","DGMSTAPI",64,0) ; Callpoint to create a new MST HISTORY FILE (#29.11) entry. "RTN","DGMSTAPI",65,0) ; Will also queue HL7 message for HEC database updates. "RTN","DGMSTAPI",66,0) ; "RTN","DGMSTAPI",67,0) ; Input "RTN","DGMSTAPI",68,0) ; DFN - Patients DFN "RTN","DGMSTAPI",69,0) ; DGSTAT - MST Status code, "Y,N,D,U" "RTN","DGMSTAPI",70,0) ; DGDATE - Date of MST status change [default=NOW] "RTN","DGMSTAPI",71,0) ; DGPROV - IEN of Provider making determination, file (#200) "RTN","DGMSTAPI",72,0) ; DGSITE - IEN pointer of the INSTITUTION file (#4) "RTN","DGMSTAPI",73,0) ; DGXMIT - HL7 transmit flag [OPTIONAL] "RTN","DGMSTAPI",74,0) ; 0=don't queue a message "RTN","DGMSTAPI",75,0) ; 1=queue a message [default]) "RTN","DGMSTAPI",76,0) ; "RTN","DGMSTAPI",77,0) ; Output "RTN","DGMSTAPI",78,0) ; DGRSLT - Returns IEN of file (#29.11) entry if successful "RTN","DGMSTAPI",79,0) ; "RTN","DGMSTAPI",80,0) ; If no patient was defined, then: "RTN","DGMSTAPI",81,0) ; DGRSLT = -1^No patient defined "RTN","DGMSTAPI",82,0) ; "RTN","DGMSTAPI",83,0) ; If an error occured in the GETS^DIQ lookup, then: "RTN","DGMSTAPI",84,0) ; DGMST = -1^^Error Code IEN "RTN","DGMSTAPI",85,0) ; (returned by GETS^DIQ call) "RTN","DGMSTAPI",86,0) ; "RTN","DGMSTAPI",87,0) N DGFDA,DGMSG,DGERR,DGRSLT,MSTIEN "RTN","DGMSTAPI",88,0) S DFN=$G(DFN) "RTN","DGMSTAPI",89,0) I DFN']""!('$D(^DPT(DFN,0))) D G NEWQ "RTN","DGMSTAPI",90,0) . S DGRSLT="-1^No patient defined" "RTN","DGMSTAPI",91,0) ; "RTN","DGMSTAPI",92,0) S DGSTAT=$S($G(DGSTAT)]"":DGSTAT,1:"U") "RTN","DGMSTAPI",93,0) S DGDATE=$G(DGDATE) "RTN","DGMSTAPI",94,0) S DGPROV=$G(DGPROV) "RTN","DGMSTAPI",95,0) S DGSITE=$G(DGSITE) "RTN","DGMSTAPI",96,0) S DGXMIT=$S($G(DGXMIT)=0:DGXMIT,1:1) "RTN","DGMSTAPI",97,0) S DGDATE=$S(+DGDATE>0:DGDATE,1:$$NOW^XLFDT) "RTN","DGMSTAPI",98,0) S DGSITE=$S(+DGSITE>0:DGSITE,1:$$SITE) "RTN","DGMSTAPI",99,0) ; "RTN","DGMSTAPI",100,0) I '$$CHANGE(DFN,DGSTAT,DGDATE) D G NEWQ "RTN","DGMSTAPI",101,0) . S DGRSLT="0" "RTN","DGMSTAPI",102,0) ; "RTN","DGMSTAPI",103,0) I '$$VALID(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,.DGERR) D G NEWQ "RTN","DGMSTAPI",104,0) . S DGRSLT="-1^"_DGERR "RTN","DGMSTAPI",105,0) ; "RTN","DGMSTAPI",106,0) S DGFDA(1,29.11,"+1,",.01)=DGDATE "RTN","DGMSTAPI",107,0) S DGFDA(1,29.11,"+1,",2)=DFN "RTN","DGMSTAPI",108,0) S DGFDA(1,29.11,"+1,",3)=DGSTAT "RTN","DGMSTAPI",109,0) S DGFDA(1,29.11,"+1,",4)=DGPROV "RTN","DGMSTAPI",110,0) S DGFDA(1,29.11,"+1,",5)=DUZ "RTN","DGMSTAPI",111,0) S DGFDA(1,29.11,"+1,",6)=DGSITE "RTN","DGMSTAPI",112,0) ; "RTN","DGMSTAPI",113,0) D UPDATE^DIE("","DGFDA(1)","MSTIEN","DGERR") "RTN","DGMSTAPI",114,0) I $D(DGERR) D G NEWQ "RTN","DGMSTAPI",115,0) . S DGRSLT="-1^"_$G(DGERR("DIERR",1)) "RTN","DGMSTAPI",116,0) ; "RTN","DGMSTAPI",117,0) S DGRSLT=+MSTIEN(1) "RTN","DGMSTAPI",118,0) ; "RTN","DGMSTAPI",119,0) ; Callpoint to queue an entry that will trigger a HEC "RTN","DGMSTAPI",120,0) ; Enrollment Full Data Transmission (ORF/ORU~ZO7) HL7 message. "RTN","DGMSTAPI",121,0) ; The HL7 message will contain the following three MST data elments "RTN","DGMSTAPI",122,0) ; as part of the VA-Specific Eligibility ZEL segment: "RTN","DGMSTAPI",123,0) ; (23) - MST STATUS "RTN","DGMSTAPI",124,0) ; (24) - DATE MST STATUS CHANGED "RTN","DGMSTAPI",125,0) ; (25) - SITE DETERMINING MST STATUS "RTN","DGMSTAPI",126,0) ; "RTN","DGMSTAPI",127,0) I DGXMIT D "RTN","DGMSTAPI",128,0) . D SEND^DGMSTL1(DFN,"Z07") "RTN","DGMSTAPI",129,0) ; "RTN","DGMSTAPI",130,0) NEWQ Q $G(DGRSLT) "RTN","DGMSTAPI",131,0) ; "RTN","DGMSTAPI",132,0) DELMST(MSTIEN) ; Deletes the MST HISTORY File (#29.11) entry passed in. "RTN","DGMSTAPI",133,0) ; This call is not to be used except from inside the DG MST List "RTN","DGMSTAPI",134,0) ; Manager interface. "RTN","DGMSTAPI",135,0) ; "RTN","DGMSTAPI",136,0) ; Input "RTN","DGMSTAPI",137,0) ; MSTIEN - IEN of the entry in the MST HISTORY File (#29.11) "RTN","DGMSTAPI",138,0) ; "RTN","DGMSTAPI",139,0) ; Output "RTN","DGMSTAPI",140,0) ; If no IEN passed in, return -1 "RTN","DGMSTAPI",141,0) ; otherwise return 1 "RTN","DGMSTAPI",142,0) ; "RTN","DGMSTAPI",143,0) Q:'$G(MSTIEN) "-1^No entry to delete" "RTN","DGMSTAPI",144,0) ; "RTN","DGMSTAPI",145,0) N DA,XD "RTN","DGMSTAPI",146,0) S DA=+$G(MSTIEN) "RTN","DGMSTAPI",147,0) S DIK="^DGMS(29.11," "RTN","DGMSTAPI",148,0) D ^DIK K DIK "RTN","DGMSTAPI",149,0) Q 1 "RTN","DGMSTAPI",150,0) ; "RTN","DGMSTAPI",151,0) NAME(DA) ; Returns name from the VA NEW PERSON File using DIQ call "RTN","DGMSTAPI",152,0) ; "RTN","DGMSTAPI",153,0) N DGNAME,DGPROV,DIQ,DR,DIC "RTN","DGMSTAPI",154,0) I $G(DA)="" G NAMEQ "RTN","DGMSTAPI",155,0) S DIC=200,DR=".01",DIQ="DGPROV" "RTN","DGMSTAPI",156,0) D EN^DIQ1 "RTN","DGMSTAPI",157,0) S DGNAME=$G(DGPROV(200,DA,.01)) "RTN","DGMSTAPI",158,0) NAMEQ Q $G(DGNAME) "RTN","DGMSTAPI",159,0) ; "RTN","DGMSTAPI",160,0) CHANGE(DFN,DGSTAT,DGDATE) ;Did the Status OR Date change? "RTN","DGMSTAPI",161,0) ; Input "RTN","DGMSTAPI",162,0) ; DFN - Patients DFN "RTN","DGMSTAPI",163,0) ; DGSTAT - MST Status code, "Y,N,D,U" "RTN","DGMSTAPI",164,0) ; DGDATE - Date of MST Status Change (FM format) "RTN","DGMSTAPI",165,0) ; "RTN","DGMSTAPI",166,0) ; Output "RTN","DGMSTAPI",167,0) ; Returns 0 if no status change "RTN","DGMSTAPI",168,0) ; 1 if status changed "RTN","DGMSTAPI",169,0) ; "RTN","DGMSTAPI",170,0) N DGCHG,DGMST "RTN","DGMSTAPI",171,0) S DGCHG=0 "RTN","DGMSTAPI",172,0) I +$G(DFN)'>0!('$D(^DPT(DFN,0))) G CHNGQ "RTN","DGMSTAPI",173,0) S DGSTAT=$G(DGSTAT) "RTN","DGMSTAPI",174,0) I DGSTAT'?1A!("YNDU"'[DGSTAT) G CHNGQ "RTN","DGMSTAPI",175,0) S DGDATE=$G(DGDATE) "RTN","DGMSTAPI",176,0) I DGDATE="" G CHNGQ "RTN","DGMSTAPI",177,0) S DGMST=$$GETSTAT(DFN),DGMST=$G(DGMST) "RTN","DGMSTAPI",178,0) I +DGMST<1!($P(DGMST,U,2)'=$G(DGSTAT))!($P(DGMST,U,3)'=$G(DGDATE)) S DGCHG=1 "RTN","DGMSTAPI",179,0) CHNGQ Q DGCHG "RTN","DGMSTAPI",180,0) ; "RTN","DGMSTAPI",181,0) SITE(DGSITE) ;Convert a station number into a pointer to the "RTN","DGMSTAPI",182,0) ; INSTITUTION file (#4). If called with a null parameter then "RTN","DGMSTAPI",183,0) ; the pointer to the INSTITUTION file (#4) of the primary site "RTN","DGMSTAPI",184,0) ; will be returned. "RTN","DGMSTAPI",185,0) ; "RTN","DGMSTAPI",186,0) ; Input "RTN","DGMSTAPI",187,0) ; DGSITE - Station number (optional) "RTN","DGMSTAPI",188,0) ; "RTN","DGMSTAPI",189,0) ; Output "RTN","DGMSTAPI",190,0) ; Return Site IEN to INSTITUTION file (#4) "RTN","DGMSTAPI",191,0) ; "RTN","DGMSTAPI",192,0) S DGSITE=$G(DGSITE) "RTN","DGMSTAPI",193,0) I DGSITE]"",$D(^DIC(4,"D",DGSITE)) D "RTN","DGMSTAPI",194,0) . S DGSITE=$O(^DIC(4,"D",DGSITE,0)) "RTN","DGMSTAPI",195,0) E D "RTN","DGMSTAPI",196,0) . S DGSITE=$P($$SITE^VASITE,U) "RTN","DGMSTAPI",197,0) I +DGSITE'>0 S DGSITE="" "RTN","DGMSTAPI",198,0) Q DGSITE "RTN","DGMSTAPI",199,0) ; "RTN","DGMSTAPI",200,0) DATE(DFN,DGDT) ;Determine 'current' MST date "RTN","DGMSTAPI",201,0) ; "RTN","DGMSTAPI",202,0) ; Input "RTN","DGMSTAPI",203,0) ; DFN - Patient's DFN "RTN","DGMSTAPI",204,0) ; DGDT - FileMan format date "RTN","DGMSTAPI",205,0) ; "RTN","DGMSTAPI",206,0) ; Output "RTN","DGMSTAPI",207,0) ; Return MST effective date "RTN","DGMSTAPI",208,0) ; "RTN","DGMSTAPI",209,0) N DGMSTDT "RTN","DGMSTAPI",210,0) S DFN=$G(DFN) "RTN","DGMSTAPI",211,0) I '+DFN D G DATEQ "RTN","DGMSTAPI",212,0) . S DGMSTDT="" "RTN","DGMSTAPI",213,0) S DGDT=$S(+$G(DGDT)>0:DGDT,1:$$NOW^XLFDT) "RTN","DGMSTAPI",214,0) I $P(DGDT,".",2)="" S DGDT=DGDT_".999999" "RTN","DGMSTAPI",215,0) S DGMSTDT=$O(^DGMS(29.11,"APDT",DFN,DGDT),-1) "RTN","DGMSTAPI",216,0) DATEQ Q DGMSTDT "RTN","DGMSTAPI",217,0) ; "RTN","DGMSTAPI",218,0) VALID(DFN,DGSTAT,DGDATE,DGPROV,DGSITE,DGERR) ;Validate fields before filing "RTN","DGMSTAPI",219,0) ; Input: "RTN","DGMSTAPI",220,0) ; DFN - [REQUIRED] - ien of Patient "RTN","DGMSTAPI",221,0) ; DGSTAT - [REQUIRED] - MST Status code, "Y,N,D,U" "RTN","DGMSTAPI",222,0) ; DGDATE - [REQUIRED] - Date of MST status change[FileMan Internal] "RTN","DGMSTAPI",223,0) ; DGPROV - [optional] - IEN of Provider making determination "RTN","DGMSTAPI",224,0) ; DGSITE - [optional] - IEN pointer of the INSTITUTION file "RTN","DGMSTAPI",225,0) ; DGERR - [optional] - error parameter passed by reference "RTN","DGMSTAPI",226,0) ; Output: "RTN","DGMSTAPI",227,0) ; Function Value - Returns 1 - if validation checks passed "RTN","DGMSTAPI",228,0) ; 0 - if validation checks failed "RTN","DGMSTAPI",229,0) ; DGERR - an error message if validation checks fail "RTN","DGMSTAPI",230,0) ; init variables "RTN","DGMSTAPI",231,0) N I,DGFILE,DGFLD,DGMSG,DGSTR,DGVAL,DGVAR,DGX,VALID "RTN","DGMSTAPI",232,0) S DGFILE=29.11,VALID=1,DGMSG=" IS REQUIRED" "RTN","DGMSTAPI",233,0) ; Quit DO block if invalid condition found "RTN","DGMSTAPI",234,0) ; Check for [REQUIRED] fields "RTN","DGMSTAPI",235,0) D "RTN","DGMSTAPI",236,0) . I DFN="" D MSG(DGFILE,2,DGMSG,.DGERR) Q ;pat ien "RTN","DGMSTAPI",237,0) . I DGSTAT="" D MSG(DGFILE,3,DGMSG,.DGERR) Q ;mst status code "RTN","DGMSTAPI",238,0) . I DGDATE="" D MSG(DGFILE,.01,DGMSG,.DGERR) Q ;dt chg status "RTN","DGMSTAPI",239,0) .; "RTN","DGMSTAPI",240,0) .; Check for valid FIELD values "RTN","DGMSTAPI",241,0) . S DGMSG=" IS NOT VALID" "RTN","DGMSTAPI",242,0) .; need to strip off the 'seconds' to pass the CHK^DIE() call... "RTN","DGMSTAPI",243,0) . I DGDATE["." N DGSECS S DGSECS=$E($P(DGDATE,".",2),5,6) I DGSECS'="" I DGSECS<0!(DGSECS>60) D MSG(DGFILE,.01,DGMSG,.DGERR) Q "RTN","DGMSTAPI",244,0) . N DGDATEX S DGDATEX=DGDATE "RTN","DGMSTAPI",245,0) . I DGDATEX["." S DGDATEX=$P(DGDATEX,".")_"."_$E($P(DGDATEX,".",2),1,4) "RTN","DGMSTAPI",246,0) . I $E($P(DGDATEX,".",2),1,4)="0000" S DGDATEX=$P(DGDATEX,".")_".1" "RTN","DGMSTAPI",247,0) . S DGSTR=".01;DGDATEX^2;DFN^3;DGSTAT^4;DGPROV^5;DUZ^6;DGSITE" "RTN","DGMSTAPI",248,0) .; "RTN","DGMSTAPI",249,0) . F I=1:1:$L(DGSTR,U) S DGX=$P(DGSTR,U,I) Q:DGX="" D Q:'VALID "RTN","DGMSTAPI",250,0) .. S DGFLD=$P(DGX,";"),DGVAR=$P(DGX,";",2),DGVAL=@DGVAR "RTN","DGMSTAPI",251,0) .. Q:DGVAL="" "RTN","DGMSTAPI",252,0) .. S VALID=$$TESTVAL(DGFILE,DGFLD,DGVAL) "RTN","DGMSTAPI",253,0) .. D:'VALID MSG(DGFILE,DGFLD,DGMSG,.DGERR) "RTN","DGMSTAPI",254,0) Q VALID "RTN","DGMSTAPI",255,0) ; "RTN","DGMSTAPI",256,0) MSG(DGFIL,DGFLD,DGMSG,DGERR) ; error message setup "RTN","DGMSTAPI",257,0) ; Input: "RTN","DGMSTAPI",258,0) ; DGFIL - file number "RTN","DGMSTAPI",259,0) ; DGFLD - field number of file "RTN","DGMSTAPI",260,0) ; DGMSG - message type verbiage - " IS REQUIRED" or " IS NOT VALID" "RTN","DGMSTAPI",261,0) ; DGERR - error parameter passed by reference "RTN","DGMSTAPI",262,0) ; Output: "RTN","DGMSTAPI",263,0) ; DGERR - error message "RTN","DGMSTAPI",264,0) S DGERR=$$GET1^DID(DGFIL,DGFLD,,"LABEL")_DGMSG "RTN","DGMSTAPI",265,0) Q "RTN","DGMSTAPI",266,0) ; "RTN","DGMSTAPI",267,0) TESTVAL(DGFIL,DGFLD,DGVAL) ; Determine if a field value is valid. "RTN","DGMSTAPI",268,0) ; Input: "RTN","DGMSTAPI",269,0) ; DGFIL - file number "RTN","DGMSTAPI",270,0) ; DGFLD - field number of file "RTN","DGMSTAPI",271,0) ; DGVAL - field value to be validated "RTN","DGMSTAPI",272,0) ; Output: "RTN","DGMSTAPI",273,0) ; Function value: Returns 1 if field is valid "RTN","DGMSTAPI",274,0) ; 0 if validation fails "RTN","DGMSTAPI",275,0) N DGVALEX,DGRSLT,VALID "RTN","DGMSTAPI",276,0) S VALID=1 "RTN","DGMSTAPI",277,0) I DGVAL'="" D "RTN","DGMSTAPI",278,0) . S DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL) "RTN","DGMSTAPI",279,0) . I DGVALEX="" S VALID=0 Q ; no external value, not valid "RTN","DGMSTAPI",280,0) . I $$GET1^DID(DGFIL,DGFLD,"","TYPE")'="POINTER" D "RTN","DGMSTAPI",281,0) .. D CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT) I DGRSLT="^" S VALID=0 "RTN","DGMSTAPI",282,0) Q VALID "RTN","GMRCA2") 0^35^B10634 "RTN","GMRCA2",1,0) GMRCA2 ;SLC/KCM,DLT,MSC/JDA - Select prompt for processing actions ;27APR2009 "RTN","GMRCA2",2,0) ;;3.0;CONSULT/REQUEST TRACKING;**1,4,MSC**;DEC 27, 1997 "RTN","GMRCA2",3,0) SELECT(GMRCO) ; Select the consult to process "RTN","GMRCA2",4,0) ;This utility checks the GMRCO variable against the selection list "RTN","GMRCA2",5,0) ; Input variable used: "RTN","GMRCA2",6,0) ; BLK, LNCT, GMRCO "RTN","GMRCA2",7,0) ; GMRC("NMBR") "RTN","GMRCA2",8,0) ; Output variables returned: "RTN","GMRCA2",9,0) ; GMRCQUT=1 if no consult was selected "RTN","GMRCA2",10,0) ; GMRCQUT is not defined on return when selection made "RTN","GMRCA2",11,0) ; GMRCO= consult selected from list "RTN","GMRCA2",12,0) START "RTN","GMRCA2",13,0) K GMRCQUT,GMRCSEL "RTN","GMRCA2",14,0) N GMRCAGN "RTN","GMRCA2",15,0) I '$L($G(GMRCO)) D Q:$D(GMRCQUT) G:$D(GMRCAGN) START "RTN","GMRCA2",16,0) .;use the highlighted number if defined "RTN","GMRCA2",17,0) .I $D(GMRC("NMBR")) S GMRCSEL=GMRC("NMBR") "RTN","GMRCA2",18,0) .I '$D(GMRCSEL),$D(LNCT),LNCT=1 S GMRCSEL=LNCT "RTN","GMRCA2",19,0) .I $S('+$G(GMRCSEL):1,+GMRCSEL<1:1,+GMRCSEL>BLK:1,GMRCSEL="":1,1:0) K GMRCSEL D:+$G(GMRC("NMBR")) AGAIN^GMRCSLMV(GMRC("NMBR")) K GMRC("NMBR") "RTN","GMRCA2",20,0) .I '+$G(GMRCSEL) D SEL I $S($D(DTOUT):1,$D(DIROUT):1,$D(GMRCQUT):1,'+GMRCSEL:1,1:0) K GMRCSEL S GMRCQUT=1 Q "RTN","GMRCA2",21,0) .I $S(+GMRCSEL<1:1,GMRCSEL>BLK:1,1:0) W !,"Select a consult listed in the number range 1 to "_BLK S GMRCAGN=1 Q "RTN","GMRCA2",22,0) .S GMRCO=$O(^TMP("GMRCR",$J,"CS","AD",GMRCSEL,GMRCSEL,0)) "RTN","GMRCA2",23,0) .I '+GMRCO D "RTN","GMRCA2",24,0) .. S GMRCQUT=1 "RTN","GMRCA2",25,0) .. W !,$C(7),"Select a consult by entering its listed number between 1 and "_LNCT_"." "RTN","GMRCA2",26,0) .. K GMRCO,GMRCSEL "RTN","GMRCA2",27,0) . Q "RTN","GMRCA2",28,0) Q "RTN","GMRCA2",29,0) ; "RTN","GMRCA2",30,0) SEL ;Select order number(s) exit: GMRCSEL "RTN","GMRCA2",31,0) I $D(GMRC("NMBR")) S GMRCSEL=GMRC("NMBR") Q "RTN","GMRCA2",32,0) I '$D(^TMP("GMRCR",$J,"CS","AD")) W !,"No orders to select.",! S GMRCQUT=1,GMRCSEL="" Q "RTN","GMRCA2",33,0) I '$O(^TMP("GMRCR",$J,"CS","AD")),BLK=1 S GMRCSEL=BLK Q "RTN","GMRCA2",34,0) S GMRCSEL="" W !,"CHOOSE No. 1-",BLK,": " R X:DTIME S:X="^^" DIROUT=1 I '$T!(X["^") S (DTOUT,GMRCQUT)=1 Q "RTN","GMRCA2",35,0) I X["?" D SELHELP G SEL "RTN","GMRCA2",36,0) I X="" S GMRCQUT=1 Q "RTN","GMRCA2",37,0) I X'?.3N W $C(7)," ?? Enter the number from the far left of the list." G SEL "RTN","GMRCA2",38,0) I $S(X>BLK:1,X<1:1,1:0) D SELHELP G SEL "RTN","GMRCA2",39,0) S GMRCSEL=X "RTN","GMRCA2",40,0) Q "RTN","GMRCA2",41,0) SELHELP ;Help to select a valid entry "RTN","GMRCA2",42,0) W !,"Select a request by typing the number from the left column and pressing .",! "RTN","GMRCA2",43,0) Q "RTN","GMRCA2",44,0) UP ;Convert lower to upper case entry: X exit: X "RTN","GMRCA2",45,0) F %=1:1:$L(X) I $E(X,%)?1L S X=$E(X,1,%-1)_$C($A(X,%)-32)_$E(X,%+1,99) "RTN","GMRCA2",46,0) Q "RTN","HLCSLNCH") 0^18^B37355917 "RTN","HLCSLNCH",1,0) HLCSLNCH ;ALB/MTC/JC MSC/JDA - START AND STOP THE LLP ;13APR2009 "RTN","HLCSLNCH",2,0) ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109,MSC**;Oct 13, 1995 "RTN","HLCSLNCH",3,0) ; "RTN","HLCSLNCH",4,0) ;This program is callable from a menu "RTN","HLCSLNCH",5,0) ;It allows the user to Start and Stop the Lower Layer "RTN","HLCSLNCH",6,0) ;Protocol in the Background or in the foreground "RTN","HLCSLNCH",7,0) ; "RTN","HLCSLNCH",8,0) ;Required or Optional INPUT PARAMETERS "RTN","HLCSLNCH",9,0) ; None "RTN","HLCSLNCH",10,0) ; "RTN","HLCSLNCH",11,0) ; "RTN","HLCSLNCH",12,0) ;Output variables "RTN","HLCSLNCH",13,0) ; HLDP=IEN of Logical Link in file #870 "RTN","HLCSLNCH",14,0) ;(optional)HLTRACE=if SET it launches the LLP in the Foreground "RTN","HLCSLNCH",15,0) ;(optional) ZTSK=if defined LLP was launched in the "RTN","HLCSLNCH",16,0) ;background "RTN","HLCSLNCH",17,0) ; "RTN","HLCSLNCH",18,0) ; "RTN","HLCSLNCH",19,0) START ; Start up the lower level protocol "RTN","HLCSLNCH",20,0) N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLQUIT,HLTRACE "RTN","HLCSLNCH",21,0) N HLPARM0,HLPARM4,HLTYPTR,HLBGR,X,Y,ZTCPU,ZTSK,ZTRTN,ZTDESC "RTN","HLCSLNCH",22,0) W !!,"This option is used to launch the lower level protocol for the" "RTN","HLCSLNCH",23,0) W !,"appropriate device. Please select the node with which you want" "RTN","HLCSLNCH",24,0) W !,"to communicate",! "RTN","HLCSLNCH",25,0) S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC G:Y<0 STARTQ "RTN","HLCSLNCH",26,0) S HLDP=+Y,HLDAPP=Y(0,0),HLTYPTR=+$P(Y(0),U,3),HLPARM0=Y(0) "RTN","HLCSLNCH",27,0) ;-- check if parameter have been setup "RTN","HLCSLNCH",28,0) ;-- check for LLP type "RTN","HLCSLNCH",29,0) I 'HLTYPTR W !,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ "RTN","HLCSLNCH",30,0) ;-- get TCP information "RTN","HLCSLNCH",31,0) S HLPARM4=$G(^HLCS(870,HLDP,400)) "RTN","HLCSLNCH",32,0) ;-- get routine (background job for LLP) "RTN","HLCSLNCH",33,0) S HLBGR=$G(^HLCS(869.1,HLTYPTR,100)) "RTN","HLCSLNCH",34,0) ;-- get environment check routine (HLQUIT should be defined in fails) "RTN","HLCSLNCH",35,0) S HLENV=$G(^HLCS(869.1,HLTYPTR,200)) "RTN","HLCSLNCH",36,0) ; "RTN","HLCSLNCH",37,0) I HLBGR="" W !,$C(7),"No routine has been specified for this LLP." G STARTQ "RTN","HLCSLNCH",38,0) ; "RTN","HLCSLNCH",39,0) ;-- execute environment check routine if HLQUIT is defined then terminate "RTN","HLCSLNCH",40,0) I HLENV'="" X HLENV G:$D(HLQUIT) STARTQ "RTN","HLCSLNCH",41,0) ;Multi-Servers, only enable the link if not OpenM "RTN","HLCSLNCH",42,0) I $P(HLPARM4,U,3)="M",$$NOTMULTI D G STARTQ "RTN","HLCSLNCH",43,0) . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. TCPIP/UCX. You must use the external service to start this LLP." "RTN","HLCSLNCH",44,0) . Q "RTN","HLCSLNCH",45,0) ; "RTN","HLCSLNCH",46,0) I $P(HLPARM0,U,10) W !,$C(7),"The LLP was last started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"." G STP1:$P(HLPARM0,U,5)'="Error" "RTN","HLCSLNCH",47,0) I $P(HLPARM0,U,11) W !,"The LLP was last shutdown on ",$$DAT2^HLUTIL1($P(HLPARM0,U,11)),"." "RTN","HLCSLNCH",48,0) I $P(HLPARM0,U,5)'="Error",'($P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4))),$P(HLPARM0,U,10)]""&($P(HLPARM0,U,11)=""),$P(HLPARM0,U,12) W !,"The LLP appears to be online already !" "RTN","HLCSLNCH",49,0) I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D G STARTQ "RTN","HLCSLNCH",50,0) . W !,$C(7),"NOTE: The lower level protocol for this application is already running." "RTN","HLCSLNCH",51,0) I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D G STARTQ "RTN","HLCSLNCH",52,0) .;4=status 9=Time Started, 10=Time Stopped, 11=Task Number "RTN","HLCSLNCH",53,0) .;14=Shutdown LLP, 3=Device Type, 18=Gross Errors "RTN","HLCSLNCH",54,0) .N HLJ,X "RTN","HLCSLNCH",55,0) .I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q "RTN","HLCSLNCH",56,0) .L +^HLCS(870,HLDP,0):2 "RTN","HLCSLNCH",57,0) .E W !,$C(7),"Unable to enable this LLP !" Q "RTN","HLCSLNCH",58,0) .S X="HLJ(870,"""_HLDP_","")" "RTN","HLCSLNCH",59,0) .S @X@(4)="Enabled",@X@(9)=$$NOW^XLFDT,@X@(14)=0 "RTN","HLCSLNCH",60,0) .D FILE^HLDIE("","HLJ","","START","HLCSLNCH") ;HL*1.6*109 "RTN","HLCSLNCH",61,0) .L -^HLCS(870,HLDP,0) "RTN","HLCSLNCH",62,0) .W !,"This LLP has been enabled!" "RTN","HLCSLNCH",63,0) .Q "RTN","HLCSLNCH",64,0) I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U) W !,"This LLP will start on node ",ZTCPU," if it is run in the Background.",! "RTN","HLCSLNCH",65,0) ; "RTN","HLCSLNCH",66,0) W ! S DIR(0)="SM^F:FOREGROUND;B:BACKGROUND;Q:QUIT" "RTN","HLCSLNCH",67,0) S DIR("A")="Method for running the receiver" "RTN","HLCSLNCH",68,0) S DIR("B")="B" "RTN","HLCSLNCH",69,0) S DIR("?",1)="Enter F for Foreground (and trace)" "RTN","HLCSLNCH",70,0) S DIR("?",2)=" B for Background (normal) or" "RTN","HLCSLNCH",71,0) S DIR("?")=" Q to quit without starting the receiver" "RTN","HLCSLNCH",72,0) D ^DIR K DIR "RTN","HLCSLNCH",73,0) Q:(Y=U)!(Y="Q") "RTN","HLCSLNCH",74,0) ; "RTN","HLCSLNCH",75,0) S HLX=$G(^HLCS(870,HLDP,0)) "RTN","HLCSLNCH",76,0) ;-- foreground "RTN","HLCSLNCH",77,0) I Y="F" S HLTRACE=1 D G STARTQ "RTN","HLCSLNCH",78,0) . X HLBGR "RTN","HLCSLNCH",79,0) ;-- background "RTN","HLCSLNCH",80,0) I Y="B" D G STARTQ "RTN","HLCSLNCH",81,0) . S ZTRTN=$P(HLBGR," ",2),HLTRACE="",ZTIO="",ZTDTH=$H "RTN","HLCSLNCH",82,0) . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")="" "RTN","HLCSLNCH",83,0) . D ^%ZTLOAD "RTN","HLCSLNCH",84,0) . W !,$S($D(ZTSK):"Job was queued as "_ZTSK_".",1:"Unable to queue job.") "RTN","HLCSLNCH",85,0) ; "RTN","HLCSLNCH",86,0) Q "RTN","HLCSLNCH",87,0) ; "RTN","HLCSLNCH",88,0) ; "RTN","HLCSLNCH",89,0) STARTQ ; "RTN","HLCSLNCH",90,0) I $G(POP) W !,?5,"-Unable to Open the Device !",!,!,?6,"Check that Port is Logged Out, and that the",!,?6,"Lower Level Protocol is not Already Running." "RTN","HLCSLNCH",91,0) Q "RTN","HLCSLNCH",92,0) ; "RTN","HLCSLNCH",93,0) STOP ; Shut down a lower level protocol.. "RTN","HLCSLNCH",94,0) N DIC,DIRUT,DTOUT,DUOUT,HLDP,HLDAPP,HLJ,HLPARM0,HLPARM4,X,Y "RTN","HLCSLNCH",95,0) W !!,"This option is used to shut down the lower level protocol for the" "RTN","HLCSLNCH",96,0) W !,"appropriate device. Please select the link which you would" "RTN","HLCSLNCH",97,0) W !,"like to shutdown.",! "RTN","HLCSLNCH",98,0) S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC K DIC Q:Y<0 "RTN","HLCSLNCH",99,0) S HLDP=+Y,HLDAPP=Y(0,0),HLPARM0=Y(0),HLPARM4=$G(^HLCS(870,HLDP,400)) "RTN","HLCSLNCH",100,0) I $P(HLPARM4,U,3)="M",$$NOTMULTI D Q "RTN","HLCSLNCH",101,0) . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. UCX. You must use the external service to disable this LLP." "RTN","HLCSLNCH",102,0) . Q "RTN","HLCSLNCH",103,0) ; "RTN","HLCSLNCH",104,0) I $P(HLPARM0,U,15) W !,$C(7),"The lower level protocol is already ",$P(HLPARM0,U,5),"." Q "RTN","HLCSLNCH",105,0) I $P(HLPARM0,U,10) W !,$C(7),"The lower level protocol was started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"." "RTN","HLCSLNCH",106,0) STP1 ; "RTN","HLCSLNCH",107,0) W ! S DIR(0)="Y",DIR("A")="Okay to shut down this job" D ^DIR K DIR "RTN","HLCSLNCH",108,0) I 'Y!($D(DIRUT))!($D(DUOUT)) W !!,"The job will not be shut down." Q "RTN","HLCSLNCH",109,0) S ; "RTN","HLCSLNCH",110,0) F L +^HLCS(870,HLDP,0):2 Q:$T "RTN","HLCSLNCH",111,0) ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown "RTN","HLCSLNCH",112,0) S X="HLJ(870,"""_HLDP_","")",@X@(4)="Halting",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1 "RTN","HLCSLNCH",113,0) I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLPARM0,U,12) S @X@(4)="Shutdown" "RTN","HLCSLNCH",114,0) D FILE^HLDIE("","HLJ","","STOP","HLCSLNCH") ; HL*1.6*109 "RTN","HLCSLNCH",115,0) I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D "RTN","HLCSLNCH",116,0) . ;pass task number to stop listener "RTN","HLCSLNCH",117,0) . S:$P(HLPARM0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLPARM0,U,12)) "RTN","HLCSLNCH",118,0) . D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10) "RTN","HLCSLNCH",119,0) . I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q "RTN","HLCSLNCH",120,0) . U IO W "**STOP**" "RTN","HLCSLNCH",121,0) . W ! "RTN","HLCSLNCH",122,0) . D CLOSE^%ZISTCP "RTN","HLCSLNCH",123,0) L -^HLCS(870,HLDP,0) "RTN","HLCSLNCH",124,0) W !,"The job for the "_HLDAPP_" Lower Level Protocol will be shut down." "RTN","HLCSLNCH",125,0) Q "RTN","HLCSLNCH",126,0) ; "RTN","HLCSLNCH",127,0) NOTMULTI() ; Returns 1 if implementation can't run multithreaded listener "RTN","HLCSLNCH",128,0) Q:^%ZOSF("OS")["GT.M" 0 "RTN","HLCSLNCH",129,0) Q $S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") "RTN","HLCSLNCH",130,0) STOPQ Q "RTN","HLCSTCP") 0^17^B32434118 "RTN","HLCSTCP",1,0) HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE MSC/JDA - (TCP/IP) MLLP ;13APR2009 "RTN","HLCSTCP",2,0) ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,MSC**;Oct 13, 1995 "RTN","HLCSTCP",3,0) ; "RTN","HLCSTCP",4,0) ; This is an implementation of the HL7 Minimal Lower Layer Protocol "RTN","HLCSTCP",5,0) ; "RTN","HLCSTCP",6,0) ;taskman entry/startup option, HLDP defined in menu entry, "RTN","HLCSTCP",7,0) Q:'$D(HLDP) "RTN","HLCSTCP",8,0) N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL "RTN","HLCSTCP",9,0) ;HLCSOUT= 1-error "RTN","HLCSTCP",10,0) I '$$INIT D EXITS("Init Error") Q "RTN","HLCSTCP",11,0) ; Start the client "RTN","HLCSTCP",12,0) I $G(HLTCPCS)="C" D Q "RTN","HLCSTCP",13,0) . ; identify process for ^%SY "RTN","HLCSTCP",14,0) . D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15)) "RTN","HLCSTCP",15,0) . D ST1 "RTN","HLCSTCP",16,0) . F D ^HLCSTCP2 Q:$$STOP!$G(HLCSOUT) "RTN","HLCSTCP",17,0) . I $G(HLCSOUT)=1 D MON("Error") H 1 Q "RTN","HLCSTCP",18,0) . I $G(HLCSOUT)=2 D EXITS("Inactive") Q "RTN","HLCSTCP",19,0) . D EXITS("Shutdown") "RTN","HLCSTCP",20,0) ; "RTN","HLCSTCP",21,0) ; identify process for ^%SY "RTN","HLCSTCP",22,0) D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15)) "RTN","HLCSTCP",23,0) ;HLCSFAIL=1 port failed to open "RTN","HLCSTCP",24,0) S HLCSFAIL=1 "RTN","HLCSTCP",25,0) ;single threaded listener "RTN","HLCSTCP",26,0) I $G(HLTCPCS)="S" D Q "RTN","HLCSTCP",27,0) . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")","S ZISQUIT=$$STOP^HLCSTCP()") "RTN","HLCSTCP",28,0) . ;couldn't open listener port "RTN","HLCSTCP",29,0) . I HLCSFAIL D EXITS("Openfail") Q "RTN","HLCSTCP",30,0) ; "RTN","HLCSTCP",31,0) ;multi-threaded listener (OpenM or GT.M) "RTN","HLCSTCP",32,0) I $G(HLTCPCS)="M",(^%ZOSF("OS")["OpenM")!(^%ZOSF("OS")["GT.M") D Q "RTN","HLCSTCP",33,0) . D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")") "RTN","HLCSTCP",34,0) Q "RTN","HLCSTCP",35,0) ; "RTN","HLCSTCP",36,0) SERVER(HLDP) ; single server using Taskman "RTN","HLCSTCP",37,0) S HLCSFAIL=0 "RTN","HLCSTCP",38,0) I '$$INIT D EXITS("Init error") Q "RTN","HLCSTCP",39,0) D ^HLCSTCP1 "RTN","HLCSTCP",40,0) I $$STOP D CLOSE^%ZISTCP,EXITS("Shutdown") S IO("C")="" Q "RTN","HLCSTCP",41,0) Q:$G(HLCSOUT)=1 "RTN","HLCSTCP",42,0) D MON("Idle") "RTN","HLCSTCP",43,0) Q "RTN","HLCSTCP",44,0) ; "RTN","HLCSTCP",45,0) SERVERS(HLDP) ; Multi-threaded server using Taskman "RTN","HLCSTCP",46,0) I '$$INIT D EXITS("Init error") Q "RTN","HLCSTCP",47,0) G LISTEN "RTN","HLCSTCP",48,0) ; "RTN","HLCSTCP",49,0) ;multiple process servers, called from an external utility "RTN","HLCSTCP",50,0) MSM ;MSM entry point, called from User-Defined Services "RTN","HLCSTCP",51,0) ;HLDP=ien in the HL LOWER LEVEL PROTOCOL PARAMETER file for the "RTN","HLCSTCP",52,0) ;HL7 Multi-Threaded SERVER "RTN","HLCSTCP",53,0) S (IO,IO(0))=$P "RTN","HLCSTCP",54,0) G LISTEN "RTN","HLCSTCP",55,0) ; "RTN","HLCSTCP",56,0) CACHEVMS(%) ;Cache'/VMS tcpip/ucx entry point, called from HLSEVEN.COM file, "RTN","HLCSTCP",57,0) ;listener, % = HLDP "RTN","HLCSTCP",58,0) I $G(%)="" D ^%ZTER Q "RTN","HLCSTCP",59,0) S (IO,IO(0))="SYS$NET",HLDP=% "RTN","HLCSTCP",60,0) ; **Cache'/VMS specific code** "RTN","HLCSTCP",61,0) O IO::5 E D MON("Openfail") Q "RTN","HLCSTCP",62,0) X "U IO:(::""-M"")" ;Packet mode like DSM "RTN","HLCSTCP",63,0) D LISTEN C IO Q "RTN","HLCSTCP",64,0) ; "RTN","HLCSTCP",65,0) EN ;vms ucx entry point, called from HLSEVEN.COM file, "RTN","HLCSTCP",66,0) ;listener, % = device^HLDP "RTN","HLCSTCP",67,0) I $G(%)="" D ^%ZTER Q "RTN","HLCSTCP",68,0) S (IO,IO(0))="SYS$NET",HLDP=$P(%,"^",2) "RTN","HLCSTCP",69,0) ; **VMS specific code, need to share device** "RTN","HLCSTCP",70,0) X "O IO:(TCPDEV):60" E D MON("Openfail") Q "RTN","HLCSTCP",71,0) LISTEN ; "RTN","HLCSTCP",72,0) N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL "RTN","HLCSTCP",73,0) I '$$INIT D ^%ZTER Q "RTN","HLCSTCP",74,0) ; identify process for ^%SY "RTN","HLCSTCP",75,0) D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15)) "RTN","HLCSTCP",76,0) ;HLLSTN used to identify a listener to tag MON "RTN","HLCSTCP",77,0) S HLLSTN=1 "RTN","HLCSTCP",78,0) ;increment job count, run server "RTN","HLCSTCP",79,0) D UPDT(1),^HLCSTCP1,EXITM "RTN","HLCSTCP",80,0) Q "RTN","HLCSTCP",81,0) ; "RTN","HLCSTCP",82,0) DCOPEN(HLDP) ;open direct connect - called from HLMA2 "RTN","HLCSTCP",83,0) Q:'$$INIT 0 "RTN","HLCSTCP",84,0) Q:HLTCPADD=""!(HLTCPORT="") 0 "RTN","HLCSTCP",85,0) Q:'$$OPEN^HLCSTCP2 0 "RTN","HLCSTCP",86,0) Q 1 "RTN","HLCSTCP",87,0) ; "RTN","HLCSTCP",88,0) INIT() ; Initialize Variables "RTN","HLCSTCP",89,0) ; HLDP should be set to the IEN or name of Logical Link, file 870 "RTN","HLCSTCP",90,0) S HLOS=$P($G(^%ZOSF("OS")),"^") "RTN","HLCSTCP",91,0) N DA,DIQUIET,DR,TMP,X,Y "RTN","HLCSTCP",92,0) S DIQUIET=1 "RTN","HLCSTCP",93,0) D DT^DICRW "RTN","HLCSTCP",94,0) I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0 "RTN","HLCSTCP",95,0) S DA=HLDP "RTN","HLCSTCP",96,0) S DR="200.02;200.021;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05" "RTN","HLCSTCP",97,0) D GETS^DIQ(870,DA,DR,"IN","TMP","TMP") "RTN","HLCSTCP",98,0) ; "RTN","HLCSTCP",99,0) I $D(TMP("DIERR")) QUIT 0 "RTN","HLCSTCP",100,0) ; -- re-transmit attempts "RTN","HLCSTCP",101,0) S HLDRETR=+$G(TMP(870,DA_",",200.02,"I")) "RTN","HLCSTCP",102,0) ; -- exceed re-transmit action "RTN","HLCSTCP",103,0) S HLRETRA=$G(TMP(870,DA_",",200.021,"I")) "RTN","HLCSTCP",104,0) ; -- block size "RTN","HLCSTCP",105,0) S HLDBSIZE=+$G(TMP(870,DA_",",200.03,"I")) "RTN","HLCSTCP",106,0) ; -- read timeout "RTN","HLCSTCP",107,0) S HLDREAD=+$G(TMP(870,DA_",",200.04,"I")) "RTN","HLCSTCP",108,0) ; -- ack timeout "RTN","HLCSTCP",109,0) S HLDBACK=+$G(TMP(870,DA_",",200.05,"I")) "RTN","HLCSTCP",110,0) ; -- uni-directional wait "RTN","HLCSTCP",111,0) S HLDWAIT=$G(TMP(870,DA_",",200.09,"I")) "RTN","HLCSTCP",112,0) ; -- tcp address "RTN","HLCSTCP",113,0) S HLTCPADD=$G(TMP(870,DA_",",400.01,"I")) "RTN","HLCSTCP",114,0) ; -- tcp port "RTN","HLCSTCP",115,0) S HLTCPORT=$G(TMP(870,DA_",",400.02,"I")) "RTN","HLCSTCP",116,0) ; -- tcp/ip service type "RTN","HLCSTCP",117,0) S HLTCPCS=$G(TMP(870,DA_",",400.03,"I")) "RTN","HLCSTCP",118,0) ; -- link persistence "RTN","HLCSTCP",119,0) S HLTCPLNK=$G(TMP(870,DA_",",400.04,"I")) "RTN","HLCSTCP",120,0) ; -- retention "RTN","HLCSTCP",121,0) S HLTCPRET=$G(TMP(870,DA_",",400.05,"I")) "RTN","HLCSTCP",122,0) ; "RTN","HLCSTCP",123,0) ; -- set defaults in case something's not set "RTN","HLCSTCP",124,0) S:HLDREAD=0 HLDREAD=10 "RTN","HLCSTCP",125,0) S:HLDBACK=0 HLDBACK=60 "RTN","HLCSTCP",126,0) S:HLDBSIZE=0 HLDBSIZE=245 "RTN","HLCSTCP",127,0) S:HLDRETR=0 HLDRETR=5 "RTN","HLCSTCP",128,0) S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15) "RTN","HLCSTCP",129,0) ; "RTN","HLCSTCP",130,0) Q 1 "RTN","HLCSTCP",131,0) ; "RTN","HLCSTCP",132,0) ST1 ;record startup in 870 for single server "RTN","HLCSTCP",133,0) ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number "RTN","HLCSTCP",134,0) ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors "RTN","HLCSTCP",135,0) N HLJ,X "RTN","HLCSTCP",136,0) F L +^HLCS(870,HLDP,0):2 Q:$T "RTN","HLCSTCP",137,0) S X="HLJ(870,"""_HLDP_","")" "RTN","HLCSTCP",138,0) S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0 "RTN","HLCSTCP",139,0) I HLTCPCS["C" S @X@(3)=$S(HLTCPLNK["Y":"PC",1:"NC") "RTN","HLCSTCP",140,0) E S @X@(3)=$S(HLTCPCS["S":"SS",HLTCPCS["M":"MS",1:"") "RTN","HLCSTCP",141,0) I @X@(3)'="NC" S @X@(9)=$$NOW^XLFDT "RTN","HLCSTCP",142,0) S:$G(ZTSK) @X@(11)=ZTSK "RTN","HLCSTCP",143,0) D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109 "RTN","HLCSTCP",144,0) L -^HLCS(870,HLDP,0) "RTN","HLCSTCP",145,0) Q "RTN","HLCSTCP",146,0) ; "RTN","HLCSTCP",147,0) MON(Y) ;Display current state & check for shutdown "RTN","HLCSTCP",148,0) ;don't display for multiple server "RTN","HLCSTCP",149,0) Q:$G(HLLSTN) "RTN","HLCSTCP",150,0) F L +^HLCS(870,HLDP,0):2 Q:$T "RTN","HLCSTCP",151,0) S $P(^HLCS(870,HLDP,0),U,5)=Y "RTN","HLCSTCP",152,0) L -^HLCS(870,HLDP,0) "RTN","HLCSTCP",153,0) Q:'$D(HLTRACE) "RTN","HLCSTCP",154,0) N X U IO(0) "RTN","HLCSTCP",155,0) W !,"IN State: ",Y "RTN","HLCSTCP",156,0) I '$$STOP D "RTN","HLCSTCP",157,0) . R !,"Type Q to Quit: ",X#1:1 "RTN","HLCSTCP",158,0) . I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1 "RTN","HLCSTCP",159,0) U IO "RTN","HLCSTCP",160,0) Q "RTN","HLCSTCP",161,0) UPDT(Y) ;update job count for multiple servers,X=1 increment "RTN","HLCSTCP",162,0) N HLJ,X "RTN","HLCSTCP",163,0) F L +^HLCS(870,HLDP,0):2 Q:$T "RTN","HLCSTCP",164,0) S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server" "RTN","HLCSTCP",165,0) ;if incrementing, set the Device Type field to Multi-Server "RTN","HLCSTCP",166,0) I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP") ;HL*1.6*109 "RTN","HLCSTCP",167,0) L -^HLCS(870,HLDP,0) "RTN","HLCSTCP",168,0) Q "RTN","HLCSTCP",169,0) STOP() ;stop flag set "RTN","HLCSTCP",170,0) N X "RTN","HLCSTCP",171,0) F L +^HLCS(870,HLDP,0):2 Q:$T "RTN","HLCSTCP",172,0) S X=+$P(^HLCS(870,HLDP,0),U,15) "RTN","HLCSTCP",173,0) L -^HLCS(870,HLDP,0) "RTN","HLCSTCP",174,0) Q X "RTN","HLCSTCP",175,0) ; "RTN","HLCSTCP",176,0) LLCNT(DP,Y,Z) ;update Logical Link counters "RTN","HLCSTCP",177,0) ;DP=ien of Logical Link in file 870 "RTN","HLCSTCP",178,0) ;Y: 1=msg rec, 2=msg proc, 3=msg to send, 4=msg sent "RTN","HLCSTCP",179,0) ;Z: ""=add to counter, 1=subtract from counter "RTN","HLCSTCP",180,0) Q:'$D(^HLCS(870,+$G(DP),0))!('$G(Y)) "RTN","HLCSTCP",181,0) N P,X "RTN","HLCSTCP",182,0) S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER" "RTN","HLCSTCP",183,0) F L +^HLCS(870,DP,P):2 Q:$T "RTN","HLCSTCP",184,0) S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1) "RTN","HLCSTCP",185,0) L -^HLCS(870,DP,P) "RTN","HLCSTCP",186,0) Q "RTN","HLCSTCP",187,0) SDFLD ; set Shutdown? field to yes "RTN","HLCSTCP",188,0) Q:'$G(HLDP) "RTN","HLCSTCP",189,0) N HLJ,X "RTN","HLCSTCP",190,0) F L +^HLCS(870,HLDP,0):2 Q:$T "RTN","HLCSTCP",191,0) ;14=Shutdown LLP? "RTN","HLCSTCP",192,0) S HLJ(870,HLDP_",",14)=1 "RTN","HLCSTCP",193,0) D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109 "RTN","HLCSTCP",194,0) L -^HLCS(870,HLDP,0) "RTN","HLCSTCP",195,0) Q "RTN","HLCSTCP",196,0) ; "RTN","HLCSTCP",197,0) EXITS(Y) ; Single service shutdown and cleans up "RTN","HLCSTCP",198,0) N HLJ,X "RTN","HLCSTCP",199,0) F L +^HLCS(870,HLDP,0):2 Q:$T "RTN","HLCSTCP",200,0) ;4=status,10=Time Stopped,9=Time Started,11=Task Number "RTN","HLCSTCP",201,0) S X="HLJ(870,"""_HLDP_","")" "RTN","HLCSTCP",202,0) S @X@(4)=Y,@X@(11)="@" "RTN","HLCSTCP",203,0) S:$G(HLCSOUT)'=2 @X@(10)=$$NOW^XLFDT,@X@(9)="@" "RTN","HLCSTCP",204,0) D FILE^HLDIE("","HLJ","","EXITS","HLCSTCP") ; HL*1.6*109 "RTN","HLCSTCP",205,0) L -^HLCS(870,HLDP,0) "RTN","HLCSTCP",206,0) I $D(ZTQUEUED) S ZTREQ="@" "RTN","HLCSTCP",207,0) Q "RTN","HLCSTCP",208,0) ; "RTN","HLCSTCP",209,0) EXITM ;Multiple service shutdown and clean up "RTN","HLCSTCP",210,0) D UPDT(0) "RTN","HLCSTCP",211,0) I $D(ZTQUEUED) S ZTREQ="@" "RTN","HLCSTCP",212,0) Q "RTN","HLCSTCP1") 0^16^B29662559 "RTN","HLCSTCP1",1,0) HLCSTCP1 ;SFIRMFO/RSD MSC/JDA - BI-DIRECTIONAL TCP ;13APR2009 "RTN","HLCSTCP1",2,0) ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,MSC**;JUL 17,1995 "RTN","HLCSTCP1",3,0) ;Receiver "RTN","HLCSTCP1",4,0) ;connection is initiated by sender and listener accepts connection "RTN","HLCSTCP1",5,0) ;and calls this routine "RTN","HLCSTCP1",6,0) ; "RTN","HLCSTCP1",7,0) N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP1" "RTN","HLCSTCP1",8,0) N HLMIEN,HLASTMSG "RTN","HLCSTCP1",9,0) D MON^HLCSTCP("Open") "RTN","HLCSTCP1",10,0) K ^TMP("HLCSTCP",$J,0) "RTN","HLCSTCP1",11,0) S HLMIEN=0,HLASTMSG="" "RTN","HLCSTCP1",12,0) F D Q:$$STOP^HLCSTCP I 'HLMIEN D MON^HLCSTCP("Idle") H 3 "RTN","HLCSTCP1",13,0) . S HLMIEN=$$READ "RTN","HLCSTCP1",14,0) . Q:'HLMIEN "RTN","HLCSTCP1",15,0) . D PROCESS "RTN","HLCSTCP1",16,0) Q "RTN","HLCSTCP1",17,0) ; "RTN","HLCSTCP1",18,0) PROCESS ;check message and reply "RTN","HLCSTCP1",19,0) ;HLDP=LL in 870, update monitor, received msg. "RTN","HLCSTCP1",20,0) N HLTCP,HLTCPI,HLTCPO "RTN","HLCSTCP1",21,0) S HLTCP="",HLTCPO=HLDP,HLTCPI=+HLMIEN "RTN","HLCSTCP1",22,0) ;update monitor, msg. received "RTN","HLCSTCP1",23,0) D LLCNT^HLCSTCP(HLDP,1) "RTN","HLCSTCP1",24,0) D NEW^HLTP3(HLMIEN) "RTN","HLCSTCP1",25,0) ;update monitor, msg. processed "RTN","HLCSTCP1",26,0) D LLCNT^HLCSTCP(HLDP,2) "RTN","HLCSTCP1",27,0) Q "RTN","HLCSTCP1",28,0) ; "RTN","HLCSTCP1",29,0) READ() ;read 1 message, returns ien in 773^ien in 772 for message "RTN","HLCSTCP1",30,0) D MON^HLCSTCP("Reading") "RTN","HLCSTCP1",31,0) N HLDB,HLDT,HLDEND,HLACKWT,HLDSTRT,HLHDR,HLIND1,HLINE,HLMSG,HLRDOUT,HLRS,HLX,X "RTN","HLCSTCP1",32,0) ;HLDSTRT=start char., HLDEND=end char., HLRS=record seperator "RTN","HLCSTCP1",33,0) S HLDSTRT=$C(11),HLDEND=$C(28),HLRS=$C(13) "RTN","HLCSTCP1",34,0) ;HLRDOUT=exit read loop, HLINE=line count, HLIND1=ien 773^ien 772 "RTN","HLCSTCP1",35,0) ;HLHDR=have a header, ^TMP(...)=excess from last read, HLACKWT=wait for ack "RTN","HLCSTCP1",36,0) S (HLRDOUT,HLINE,HLIND1,HLHDR)=0,HLX=$G(^TMP("HLCSTCP",$J,0)),HLACKWT=HLDBACK "RTN","HLCSTCP1",37,0) K ^TMP("HLCSTCP",$J,0) "RTN","HLCSTCP1",38,0) F D RDBLK Q:HLRDOUT "RTN","HLCSTCP1",39,0) ;save any excess for next time "RTN","HLCSTCP1",40,0) S:$L(HLX) ^TMP("HLCSTCP",$J,0)=HLX "RTN","HLCSTCP1",41,0) I +HLIND1,'$P(HLIND1,U,3) D DELMSG(HLIND1) S HLIND1=0 "RTN","HLCSTCP1",42,0) Q HLIND1 "RTN","HLCSTCP1",43,0) ; "RTN","HLCSTCP1",44,0) RDBLK S HLDB=HLDBSIZE-$L(HLX) "RTN","HLCSTCP1",45,0) U IO D:$D ERROR R X#HLDB:HLDREAD ; MSC/JDA added check against $d "RTN","HLCSTCP1",46,0) ; timedout or error, check ack timeout, clean up "RTN","HLCSTCP1",47,0) I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q "RTN","HLCSTCP1",48,0) ;data stream: dddd "RTN","HLCSTCP1",49,0) ;add incoming line to what wasn't processed in last read "RTN","HLCSTCP1",50,0) S HLX=$G(HLX)_X "RTN","HLCSTCP1",51,0) ; look for segment= "RTN","HLCSTCP1",52,0) F Q:HLX'[HLRS D Q:HLRDOUT "RTN","HLCSTCP1",53,0) . ; Get the first piece, save the rest of the line "RTN","HLCSTCP1",54,0) . S HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLRS),HLX=$P(HLX,HLRS,2,999) "RTN","HLCSTCP1",55,0) . ; check for start block, Quit if no ien "RTN","HLCSTCP1",56,0) . I HLMSG(HLINE,0)[HLDSTRT!HLHDR D Q "RTN","HLCSTCP1",57,0) .. D:HLMSG(HLINE,0)[HLDSTRT "RTN","HLCSTCP1",58,0) ... S X=$L(HLMSG(HLINE,0),HLDSTRT) "RTN","HLCSTCP1",59,0) ... S:X>2 HLMSG(HLINE,0)=HLDSTRT_$P(HLMSG(HLINE,0),HLDSTRT,X) "RTN","HLCSTCP1",60,0) ... S HLMSG(HLINE,0)=$P(HLMSG(HLINE,0),HLDSTRT,2) "RTN","HLCSTCP1",61,0) ... D RESET:(HLINE>1) "RTN","HLCSTCP1",62,0) .. ;ping message "RTN","HLCSTCP1",63,0) .. I $E(HLMSG(1,0),1,9)="MSH^PING^" D PING Q "RTN","HLCSTCP1",64,0) .. ; get next ien to store "RTN","HLCSTCP1",65,0) .. D MIEN "RTN","HLCSTCP1",66,0) .. K HLMSG "RTN","HLCSTCP1",67,0) .. S (HLINE,HLHDR)=0 "RTN","HLCSTCP1",68,0) . ; check for end block; HLMSG(HLINE) = "RTN","HLCSTCP1",69,0) . I HLMSG(HLINE,0)[HLDEND D "RTN","HLCSTCP1",70,0) .. ;no msg. ien "RTN","HLCSTCP1",71,0) .. Q:'HLIND1 "RTN","HLCSTCP1",72,0) .. ; Kill just the last line "RTN","HLCSTCP1",73,0) .. K HLMSG(HLINE,0) S HLINE=HLINE-1 "RTN","HLCSTCP1",74,0) .. ; move into 772 "RTN","HLCSTCP1",75,0) .. D SAVE(.HLMSG,"^HL(772,"_+$P(HLIND1,U,2)_",""IN"")") "RTN","HLCSTCP1",76,0) .. ;mark that end block has been received "RTN","HLCSTCP1",77,0) .. ;HLIND1=ien in 773^ien in 772^1 if end block was received "RTN","HLCSTCP1",78,0) .. S $P(HLIND1,U,3)=1 "RTN","HLCSTCP1",79,0) .. ;reset variables for next message "RTN","HLCSTCP1",80,0) .. D CLEAN "RTN","HLCSTCP1",81,0) . ;add blank line for carriage return "RTN","HLCSTCP1",82,0) . I HLINE'=0,HLMSG(HLINE,0)]"" S HLINE=HLINE+1,HLMSG(HLINE,0)="" "RTN","HLCSTCP1",83,0) Q:HLRDOUT "RTN","HLCSTCP1",84,0) ;If the line is long and no move it into the array. "RTN","HLCSTCP1",85,0) I ($L(HLX)=HLDBSIZE),(HLX'[HLRS),(HLX'[HLDEND),(HLX'[HLDSTRT) D Q "RTN","HLCSTCP1",86,0) . S HLINE=HLINE+1,HLMSG(HLINE,0)=HLX,HLX="" "RTN","HLCSTCP1",87,0) ;have start block but no record seperator "RTN","HLCSTCP1",88,0) I HLX[HLDSTRT D Q "RTN","HLCSTCP1",89,0) . ;check for more than 1 start block "RTN","HLCSTCP1",90,0) . S X=$L(HLX,HLDSTRT) S:X>2 HLX=HLDSTRT_$P(HLX,HLDSTRT,X) "RTN","HLCSTCP1",91,0) . S:$L($P(HLX,HLDSTRT,2))>8 HLINE=HLINE+1,HLMSG(HLINE,0)=$P(HLX,HLDSTRT,2),HLX="",HLHDR=1 "RTN","HLCSTCP1",92,0) . D RESET:(HLHDR&(HLINE>1)) "RTN","HLCSTCP1",93,0) ;if no ien, then we don't have start block, reset "RTN","HLCSTCP1",94,0) I 'HLIND1 D CLEAN Q "RTN","HLCSTCP1",95,0) ; big message-merge from local to global every 100 lines "RTN","HLCSTCP1",96,0) I (HLINE-$O(HLMSG(0)))>100 D "RTN","HLCSTCP1",97,0) . M ^HL(772,+$P(HLIND1,U,2),"IN")=HLMSG "RTN","HLCSTCP1",98,0) . ; reset working array "RTN","HLCSTCP1",99,0) . K HLMSG "RTN","HLCSTCP1",100,0) Q "RTN","HLCSTCP1",101,0) ; "RTN","HLCSTCP1",102,0) SAVE(SRC,DEST) ;save into global & set top node "RTN","HLCSTCP1",103,0) ;SRC=source array (passed by ref.), DEST=destination global "RTN","HLCSTCP1",104,0) M @DEST=SRC "RTN","HLCSTCP1",105,0) S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^" "RTN","HLCSTCP1",106,0) Q "RTN","HLCSTCP1",107,0) ; "RTN","HLCSTCP1",108,0) DELMSG(HLMAMT) ;delete message from Message Administration/Message Text files. "RTN","HLCSTCP1",109,0) N DIK,DA "RTN","HLCSTCP1",110,0) S DA=+HLMAMT,DIK="^HLMA(" "RTN","HLCSTCP1",111,0) D ^DIK "RTN","HLCSTCP1",112,0) S DA=$P(HLMAMT,U,2),DIK="^HL(772," "RTN","HLCSTCP1",113,0) D ^DIK "RTN","HLCSTCP1",114,0) Q "RTN","HLCSTCP1",115,0) MIEN ; sets HLIND1=ien in 773^ien in 772 for message "RTN","HLCSTCP1",116,0) N HLMID,X "RTN","HLCSTCP1",117,0) I HLIND1 D "RTN","HLCSTCP1",118,0) . S:'$G(^HLMA(+HLIND1,0)) HLIND1=0 "RTN","HLCSTCP1",119,0) . S:'$G(^HL(772,+$P(HLIND1,U,2),0)) HLIND1=0 "RTN","HLCSTCP1",120,0) ;msg. id is 10th of MSH & 11th for BSH or FSH "RTN","HLCSTCP1",121,0) S X=10+($E(HLMSG(1,0),1,3)'="MSH"),HLMID=$$PMSH(.HLMSG,X) "RTN","HLCSTCP1",122,0) ;if HLIND1 is set, kill old message, use HLIND1 for new "RTN","HLCSTCP1",123,0) ;message, it means we never got end block for 1st msg. "RTN","HLCSTCP1",124,0) I HLIND1 D Q "RTN","HLCSTCP1",125,0) . ;get pointer to 772, kill header "RTN","HLCSTCP1",126,0) . K ^HLMA(+HLIND1,"MSH") "RTN","HLCSTCP1",127,0) . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN") "RTN","HLCSTCP1",128,0) . S X=$$MAID^HLTF(+HLIND1,HLMID) "RTN","HLCSTCP1",129,0) . D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")") "RTN","HLCSTCP1",130,0) . S:$P(HLIND1,U,3) $P(HLIND1,U,3)="" "RTN","HLCSTCP1",131,0) D TCP^HLTF(.HLMID,.X,.HLDT) "RTN","HLCSTCP1",132,0) I 'X D Q "RTN","HLCSTCP1",133,0) . ;error - record and reset array "RTN","HLCSTCP1",134,0) . ;killing HLLSTN will allow MON^HLCSTCP to work with multi-server "RTN","HLCSTCP1",135,0) . D CLEAN K HLLSTN "RTN","HLCSTCP1",136,0) . ;error 100=LLP Could not Enqueue the Message, reset array "RTN","HLCSTCP1",137,0) . D MONITOR^HLCSDR2(100,19,HLDP),MON^HLCSTCP("ERROR") H 30 "RTN","HLCSTCP1",138,0) ;HLIND1=ien in 773^ien in 772 "RTN","HLCSTCP1",139,0) S HLIND1=X_U_+$G(^HLMA(X,0)) "RTN","HLCSTCP1",140,0) ;save MSH into 773 "RTN","HLCSTCP1",141,0) D SAVE(.HLMSG,"^HLMA("_+HLIND1_",""MSH"")") "RTN","HLCSTCP1",142,0) Q "RTN","HLCSTCP1",143,0) ; "RTN","HLCSTCP1",144,0) PMSH(MSH,P) ;get piece P from MSH array (passed by ref.) "RTN","HLCSTCP1",145,0) N FS,I,L,L1,L2,X,Y "RTN","HLCSTCP1",146,0) S FS=$E(MSH(1,0),4),(L2,Y)=0,X="" "RTN","HLCSTCP1",147,0) F I=1:1 S L1=$L($G(MSH(I,0)),FS),L=L1+Y-1 D Q:$L(X)!'$D(MSH(I,0)) "RTN","HLCSTCP1",148,0) . S:L1=1 L=L+1 "RTN","HLCSTCP1",149,0) . S:P'>L X=$P($G(MSH(I-1,0)),FS,P-L2)_$P($G(MSH(I,0)),FS,(P-Y)) "RTN","HLCSTCP1",150,0) . S L2=Y,Y=L "RTN","HLCSTCP1",151,0) Q X "RTN","HLCSTCP1",152,0) ; "RTN","HLCSTCP1",153,0) PING ;process PING message "RTN","HLCSTCP1",154,0) S X=HLMSG(1,0) "RTN","HLCSTCP1",155,0) I X[HLDEND U IO W X,! "RTN","HLCSTCP1",156,0) CLEAN ;reset var. for next message "RTN","HLCSTCP1",157,0) K HLMSG "RTN","HLCSTCP1",158,0) S HLINE=0,HLRDOUT=1 "RTN","HLCSTCP1",159,0) Q "RTN","HLCSTCP1",160,0) ; "RTN","HLCSTCP1",161,0) ERROR ; Error trap for disconnect error and return back to the read loop. "RTN","HLCSTCP1",162,0) S $ETRAP="D UNWIND^%ZTER" "RTN","HLCSTCP1",163,0) I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q "RTN","HLCSTCP1",164,0) I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q "RTN","HLCSTCP1",165,0) S HLCSOUT=1 D ^%ZTER,CC("Error") "RTN","HLCSTCP1",166,0) D UNWIND^%ZTER "RTN","HLCSTCP1",167,0) Q "RTN","HLCSTCP1",168,0) ; "RTN","HLCSTCP1",169,0) CC(X) ;cleanup and close "RTN","HLCSTCP1",170,0) D MON^HLCSTCP(X) "RTN","HLCSTCP1",171,0) H 2 "RTN","HLCSTCP1",172,0) Q "RTN","HLCSTCP1",173,0) RESET ;reset info as a result of no end block "RTN","HLCSTCP1",174,0) N % "RTN","HLCSTCP1",175,0) S HLMSG(1,0)=HLMSG(HLINE,0) "RTN","HLCSTCP1",176,0) F %=2:1:HLINE K HLMSG(%,0) "RTN","HLCSTCP1",177,0) S HLINE=1 "RTN","HLCSTCP1",178,0) Q "RTN","MAGDMEDL") 0^36^B3132920 "RTN","MAGDMEDL",1,0) MAGDMEDL ;WOIFO/LB,MSC/JDA - Routine to look up entries in the Medicine files ;27APR2009 "RTN","MAGDMEDL",2,0) ;;3.0;IMAGING;**MSC**;Mar 01, 2002 "RTN","MAGDMEDL",3,0) ;; +---------------------------------------------------------------+ "RTN","MAGDMEDL",4,0) ;; | Property of the US Government. | "RTN","MAGDMEDL",5,0) ;; | No permission to copy or redistribute this software is given. | "RTN","MAGDMEDL",6,0) ;; | Use of unreleased versions of this software requires the user | "RTN","MAGDMEDL",7,0) ;; | to execute a written test agreement with the VistA Imaging | "RTN","MAGDMEDL",8,0) ;; | Development Office of the Department of Veterans Affairs, | "RTN","MAGDMEDL",9,0) ;; | telephone (301) 734-0100. | "RTN","MAGDMEDL",10,0) ;; | | "RTN","MAGDMEDL",11,0) ;; | The Food and Drug Administration classifies this software as | "RTN","MAGDMEDL",12,0) ;; | a medical device. As such, it may not be changed in any way. | "RTN","MAGDMEDL",13,0) ;; | Modifications to this software may result in an adulterated | "RTN","MAGDMEDL",14,0) ;; | medical device under 21CFR820, the use of which is considered | "RTN","MAGDMEDL",15,0) ;; | to be a violation of US Federal Statutes. | "RTN","MAGDMEDL",16,0) ;; +---------------------------------------------------------------+ "RTN","MAGDMEDL",17,0) ;; "RTN","MAGDMEDL",18,0) Q "RTN","MAGDMEDL",19,0) SELECT(ITEM,ARRAY) ; "RTN","MAGDMEDL",20,0) ; "RTN","MAGDMEDL",21,0) SELECT2 "RTN","MAGDMEDL",22,0) N CNT,DIR,DIROUT,DIRUT,ENTRY "RTN","MAGDMEDL",23,0) S CNT=+ARRAY "RTN","MAGDMEDL",24,0) I 'CNT Q 0 "RTN","MAGDMEDL",25,0) S DIR(0)="NO^1:"_CNT,DIR("A")="Select a Medicine Procedure" "RTN","MAGDMEDL",26,0) S DIR("T")=600 D ^DIR "RTN","MAGDMEDL",27,0) I $D(DIRUT)!($D(DIROUT)) Q 0 "RTN","MAGDMEDL",28,0) S ENTRY=+Y "RTN","MAGDMEDL",29,0) I '$D(ARRAY(ENTRY)) D G SELECT2 "RTN","MAGDMEDL",30,0) . W !,"Please select an entry or use '^' to exit" "RTN","MAGDMEDL",31,0) W !,"You have selected ",$P(ARRAY(ENTRY),"^"),"." "RTN","MAGDMEDL",32,0) Q $P(ARRAY(ENTRY),"^",2) "RTN","MAGDMEDL",33,0) ; "RTN","MAGDMEDL",34,0) LOOP(ARRAY,MAGPAT,SUB,CASEDT) ; "RTN","MAGDMEDL",35,0) ; MAGPAT = patient's dfn "RTN","MAGDMEDL",36,0) ; SUB = Medicine specialty "RTN","MAGDMEDL",37,0) ; CASEDT = case date "RTN","MAGDMEDL",38,0) ; array(0)= 1 or 0 ^ # entries found ^ message text "RTN","MAGDMEDL",39,0) ; array(#)= formatted out dislay without delimeters "RTN","MAGDMEDL",40,0) ; array(#,1) = internal stored values "RTN","MAGDMEDL",41,0) ; Variable MAGDIMG "RTN","MAGDMEDL",42,0) S ARRAY(0)="0^^No entries found" "RTN","MAGDMEDL",43,0) Q:'MAGPAT "RTN","MAGDMEDL",44,0) Q:'$D(MAGMC)#10 ;Array should be available. "RTN","MAGDMEDL",45,0) N BEG,CDT,CNT,DATA,DIOCM,EN,END,IMG,IMAGEPTR,MAGDIMG,PATIENT,PATNME,PRCNM,SSN,THEDT,X1,X2,X "RTN","MAGDMEDL",46,0) N IEN,II,IOUT,MAGMC,MEDFILE "RTN","MAGDMEDL",47,0) Q:'$$FIND1^DIC(2,,"A",MAGPAT,"","") "RTN","MAGDMEDL",48,0) S PATNME=$P(^DPT(MAGPAT,0),"^"),SSN=$P(^(0),"^",9) "RTN","MAGDMEDL",49,0) S PATIENT=PATNME_" "_SSN "RTN","MAGDMEDL",50,0) I 'CASEDT S CASEDT=DT "RTN","MAGDMEDL",51,0) S X1=CASEDT,X2=-3 D C^%DTC S BEG=X "RTN","MAGDMEDL",52,0) S END=CASEDT+.9999 "RTN","MAGDMEDL",53,0) S CNT=0,CDT=BEG-.001 "RTN","MAGDMEDL",54,0) F S CDT=$O(MAGMC(MAGPAT,SUB,CDT)) Q:'CDT!(CDT>END) D "RTN","MAGDMEDL",55,0) . S EN=0 F S EN=$O(MAGMC(MAGPAT,SUB,CDT,EN)) Q:'EN D "RTN","MAGDMEDL",56,0) . . S DATA=MAGMC(MAGPAT,SUB,CDT,EN) "RTN","MAGDMEDL",57,0) . . S PRCNM=$P(DATA,"^",2),PRC=SUB "RTN","MAGDMEDL",58,0) . . S THEDT=$P(DATA,"^"),IEN=$P(DATA,"^",5) "RTN","MAGDMEDL",59,0) . . I $D(MAGMC(MAGPAT,SUB,CDT,EN,2005)) S (IOUT,II)=0 D "RTN","MAGDMEDL",60,0) . . . F S II=$O(MAGMC(MAGPAT,SUB,CDT,EN,2005,II)) Q:'II!IOUT D "RTN","MAGDMEDL",61,0) . . . . S IMAGEPTR=MAGMC(MAGPAT,SUB,CDT,EN,2005,II) "RTN","MAGDMEDL",62,0) . . . . I '$D(^MAG(2005,IMAGEPTR)) S IMAGEPTR="" Q "RTN","MAGDMEDL",63,0) . . . . I '$D(^MAG(2005,IMAGEPTR,"PACS")) S IMAGEPTR="",IOUT=1 "RTN","MAGDMEDL",64,0) . . S MEDFILE=$P(DATA,"^",4),MEDFILE=$P(MEDFILE,"MCAR(",2) "RTN","MAGDMEDL",65,0) . . S DICOM="" D DICOMID^MAGDMEDI(.DICOM,MEDFILE,IEN,PRC,MAGPAT) "RTN","MAGDMEDL",66,0) . . I DICOM'="" D "RTN","MAGDMEDL",67,0) . . . S DICOM=$P(DICOM,":",2) "RTN","MAGDMEDL",68,0) . . . S CNT=CNT+1 "RTN","MAGDMEDL",69,0) . . . S ARRAY(CNT)=DICOM_" "_PRCNM_", "_THEDT_" "_PATIENT "RTN","MAGDMEDL",70,0) . . . S ARRAY(CNT,1)=DICOM_"^"_PATNME_"^"_SSN_"^"_EN_"^"_PRCNM_"^"_PRC_"^"_$G(IMAGEPTR)_"^"_MEDFILE "RTN","MAGDMEDL",71,0) I CNT S ARRAY(0)="1^"_CNT_"^Medicine file entries for "_PATIENT "RTN","MAGDMEDL",72,0) Q "RTN","MAGDMEDL",73,0) DISPLAY(ARRAY) ; "RTN","MAGDMEDL",74,0) ; Call routine needs to pass array in the following sequence "RTN","MAGDMEDL",75,0) ; ARRAY(0)= 1 or 0 ^ #entries ^ message "RTN","MAGDMEDL",76,0) ; ARRAY(#)= Formatted output to be displayed. "RTN","MAGDMEDL",77,0) ; Will set the RES variable for selected entry. "RTN","MAGDMEDL",78,0) I '$D(ARRAY(0)) Q 0 "RTN","MAGDMEDL",79,0) ; If only one entry return the subscript variable. "RTN","MAGDMEDL",80,0) I $P(ARRAY(0),"^",2)=1 Q 1 "RTN","MAGDMEDL",81,0) I $P(ARRAY(0),"^")'=1 Q 0 "RTN","MAGDMEDL",82,0) N ENTRY,ITEM,ITEMS,MSG,OUT,OUTPUT,RES "RTN","MAGDMEDL",83,0) S RES=0,MSG=$P(ARRAY(0),"^",3) "RTN","MAGDMEDL",84,0) S IOF="#,$C(27,91,72,27,91,74,8,8,8,8)",IO=0,IOSL=24,POP=0 "RTN","MAGDMEDL",85,0) D HEAD "RTN","MAGDMEDL",86,0) S (ENTRY,OUT)=0,ITEMS=$P(ARRAY(0),"^",2) "RTN","MAGDMEDL",87,0) F S ENTRY=$O(ARRAY(ENTRY)) Q:'ENTRY!OUT D "RTN","MAGDMEDL",88,0) . S OUTPUT=$G(ARRAY(ENTRY)) "RTN","MAGDMEDL",89,0) . D:$Y+3>IOSL HEAD D LINE "RTN","MAGDMEDL",90,0) . D:$Y+3>IOSL ASKQ "RTN","MAGDMEDL",91,0) I 'OUT D ASKQ S RES=ITEM "RTN","MAGDMEDL",92,0) Q RES "RTN","MAGDMEDL",93,0) HEAD ; "RTN","MAGDMEDL",94,0) W:$Y+3>IOSL @IOF W !,MSG "RTN","MAGDMEDL",95,0) Q "RTN","MAGDMEDL",96,0) LINE ; "RTN","MAGDMEDL",97,0) W !,ENTRY,".) "_OUTPUT "RTN","MAGDMEDL",98,0) Q "RTN","MAGDMEDL",99,0) ASKQ ; "RTN","MAGDMEDL",100,0) N X,Y,DIR "RTN","MAGDMEDL",101,0) S DIR(0)="L^1:"_$S('ENTRY:ITEMS,1:ENTRY) "RTN","MAGDMEDL",102,0) S DIR("T")=600,DIR("A")="Select an entry: " D ^DIR "RTN","MAGDMEDL",103,0) S ITEM=+Y "RTN","MAGDMEDL",104,0) Q:$D(DIRUT)!($D(DIROUT)) "RTN","MAGDMEDL",105,0) Q:'ITEM "RTN","MAGDMEDL",106,0) I '$D(ARRAY(ITEM)) W !,"Please select an entry or '^' to exit" G ASKQ "RTN","MAGDMEDL",107,0) W !,"You have selected ",$P($G(ARRAY(ITEM)),"^") "RTN","MAGDMEDL",108,0) S OUT=1 "RTN","MAGDMEDL",109,0) Q "RTN","MAGDMEDL",110,0) ASKMORE() ; "RTN","MAGDMEDL",111,0) N DIR,DATE,X,XX,Y "RTN","MAGDMEDL",112,0) Q:'$D(MAGPAT) "RTN","MAGDMEDL",113,0) Q:'$D(SUB) "RTN","MAGDMEDL",114,0) S DIR(0)="Y",DIR("B")="NO" "RTN","MAGDMEDL",115,0) S DIR("A")="Search further" "RTN","MAGDMEDL",116,0) D ^DIR K DIR "RTN","MAGDMEDL",117,0) I 'Y Q 0 "RTN","MAGDMEDL",118,0) W !,"Search will include 3 days prior to the day specified." "RTN","MAGDMEDL",119,0) S DIR(0)="D^::EXP" D ^DIR "RTN","MAGDMEDL",120,0) ; Y2K compliance all calls to %DT must have either past or future date "RTN","MAGDMEDL",121,0) I 'Y Q 0 "RTN","MAGDMEDL",122,0) S DATE=Y "RTN","MAGDMEDL",123,0) D LOOP(.XX,MAGPAT,SUB,DATE) "RTN","MAGDMEDL",124,0) I $D(XX(0)),$P(XX(0),"^")=0 D Q 0 "RTN","MAGDMEDL",125,0) . W "No entries found." "RTN","MAGDMEDL",126,0) Q 1 "RTN","MSCGUX53") 0^^B360592 "RTN","MSCGUX53",1,0) MSCGUX53 ;MSC/JDS - ENVIRONMENT CHECK ; ; 29 Apr 2009 1:47 PM "RTN","MSCGUX53",2,0) ;;**MSC**; "RTN","MSCGUX53",3,0) I $G(^%ZOSF("OS"))'["GT.M" Q ;Not GTM "RTN","MSCGUX53",4,0) I $P($ZV,"V",2)<5.3 D MESS^XPDUL("GT.M version must be 5.3 or Greater") S XPDABORT=2 "RTN","MSCGUX53",5,0) "RTN","MSCGUX53",6,0) "RTN","MSCGUX53",7,0) "RTN","MSCXUS3A") 0^31^B8005003 "RTN","MSCXUS3A",1,0) MSCXUS3A ;SF-ISC/STAFF MSC/JDS - CHANGE UCI'S ;30APR2009 "RTN","MSCXUS3A",2,0) ;;8.0;KERNEL;**13,282,MSC**;Jul 10, 1995 "RTN","MSCXUS3A",3,0) Q "RTN","MSCXUS3A",4,0) ;PICK A UCI TO SWITCH TO "RTN","MSCXUS3A",5,0) SWITCH ;Allow users that have the UCI fIeld In there NP fIle to swItch UCI's. "RTN","MSCXUS3A",6,0) W !!,"Switch UCI's optIon.",! "RTN","MSCXUS3A",7,0) ;I $$PROGMODE^%ZOSV() W !,$C(7),"No switching UCI's In Programmer Mode." Q "RTN","MSCXUS3A",8,0) N DIR,X,Y,PGM,%UCI,DEF,L,USERNAME "RTN","MSCXUS3A",9,0) S DEF="ZU" ;DEF is default routine to swItch to. "RTN","MSCXUS3A",10,0) UCI Q:'$G(DUZ) S USERNAME=$P($G(^VA(200,DUZ,0)),U) Q:USERNAME="" "RTN","MSCXUS3A",11,0) S DIR(0)="S^"_$$NSP(USERNAME) I DIR(0)'[";" W "YOU AREN'T A USER IN ANY OTHER NAMESPACE" Q "RTN","MSCXUS3A",12,0) S DIR("A")="Select NAMESPACE" "RTN","MSCXUS3A",13,0) D ^DIR K DIR I $D(DUOUT)!$D(DTOUT)!(U[X) Q "RTN","MSCXUS3A",14,0) SAME I X="" Q ;Didn't select anythIng. "RTN","MSCXUS3A",15,0) ;D PM "RTN","MSCXUS3A",16,0) S (X,%UCI)=Y(0) X ^%ZOSF("UCICHECK") I 0[Y G BAD "RTN","MSCXUS3A",17,0) K XQY0 S Y=$O(^[%UCI]VA(200,"B",USERNAME,0)) "RTN","MSCXUS3A",18,0) I Y S DIR=$P($G(^[%UCI]VA(200,Y,201)),U) "RTN","MSCXUS3A",19,0) I DIR,$P($G(^[%UCI]DIC(19,DIR,0)),U,4)="M" S DUZ=Y,XQY=DIR,(DEF,PGM)="%MSCXUCI" G NXT "RTN","MSCXUS3A",20,0) BAD W !,"UCI not found!" D SHOW G UCI "RTN","MSCXUS3A",21,0) ; "RTN","MSCXUS3A",22,0) NXT ;Here we go. "RTN","MSCXUS3A",23,0) D C^XUSCLEAN K ^XUTL("XQ",$J),^XUTL($J),^TMP($J),^UTILITY($J) "RTN","MSCXUS3A",24,0) K DA G GO^%MSCXUCI "RTN","MSCXUS3A",25,0) ; "RTN","MSCXUS3A",26,0) ; "RTN","MSCXUS3A",27,0) SHOW W ! S I=0,UC="",X=$S($D(^VA(200,DUZ,201)):+^(201),1:0) "RTN","MSCXUS3A",28,0) W !,"Enter ^ to return to your current menu, or select from:" "RTN","MSCXUS3A",29,0) F I=0:0 S I=$O(^VA(200,DUZ,.2,I)) Q:I'>0 D "RTN","MSCXUS3A",30,0) . W !,?5 S UC=$G(^VA(200,DUZ,.2,I,0)),X=$P(UC,U,1),UC=$P(UC,U,2,99) "RTN","MSCXUS3A",31,0) . I UC'[":" W I "RTN","MSCXUS3A",32,0) . D PM W ?10,X X ^%ZOSF("UCICHECK") I 0[Y W " -- Not currently a valId UCI!",$C(7) Q "RTN","MSCXUS3A",33,0) . W:UC]"" ":"_UC "RTN","MSCXUS3A",34,0) . Q "RTN","MSCXUS3A",35,0) Q "RTN","MSCXUS3A",36,0) ; "RTN","MSCXUS3A",37,0) PM I X="PROD"!(X="MGR") S X=^%ZOSF(X) "RTN","MSCXUS3A",38,0) Q "RTN","MSCXUS3A",39,0) ; "RTN","MSCXUS3A",40,0) ; "RTN","MSCXUS3A",41,0) ; "RTN","MSCXUS3A",42,0) NSP(USERNAME) ;LIST OTHER NAMESPACES WHERE THIS USER IS "RTN","MSCXUS3A",43,0) N X,L,I,Y "RTN","MSCXUS3A",44,0) X ^%ZOSF("UCI") S Y=$P(Y,",") I ^%ZOSF("OS")["GT.M" G GTMNSP "RTN","MSCXUS3A",45,0) f I=1:1:$zu(90,0) s L($zu(90,2,0,I))="" ;***CACHE-SPECIFIC FROM %NSP "RTN","MSCXUS3A",46,0) S (I,L,X)="" F S I=$O(L(I)) Q:I="" I I'=Y D ;NOT THE CURRENT ONE "RTN","MSCXUS3A",47,0) .N DUZ S DUZ=$O(^[I]VA(200,"B",USERNAME,0)) Q:'DUZ "RTN","MSCXUS3A",48,0) .I $P($G(^[I]VA(200,DUZ,0)),U,3)=""!'$G(^(201)) Q ;THEY MUST HAVE ACCESS CODE AND PRIMARY MENU OPTION OVER THERE "RTN","MSCXUS3A",49,0) .S L=L+1,X=X_L_":"_I_";" "RTN","MSCXUS3A",50,0) Q X "RTN","MSCXUS3A",51,0) GTMNSP ; "RTN","MSCXUS3A",52,0) N CURRENT S CURRENT=Y "RTN","MSCXUS3A",53,0) D LIST^ZCD() "RTN","MSCXUS3A",54,0) S (I,L,X)="" F S I=$O(Y(I)) Q:'I S A=Y(I) I A'=CURRENT D ;NOT THE CURRENT ONE "RTN","MSCXUS3A",55,0) .S A=$P($ZG,"/"_$$CURRENT^ZCD_"/")_"/"_A_"/"_$P($ZG,"/"_$$CURRENT^ZCD_"/",2) "RTN","MSCXUS3A",56,0) .N DUZ S DUZ=$O(^[A]VA(200,"B",USERNAME,0)) Q:'DUZ "RTN","MSCXUS3A",57,0) .I $P($G(^[A]VA(200,DUZ,0)),U,3)=""!'$G(^(201)) Q ;THEY MUST HAVE ACCESS CODE AND PRIMARY MENU OPTION OVER THERE "RTN","MSCXUS3A",58,0) .S L=L+1,X=X_L_":"_A_";" "RTN","MSCXUS3A",59,0) Q X "RTN","MSCZJOB") 0^1^B12928863 "RTN","MSCZJOB",1,0) MSCZJOB ;GFT,JDS/MSC;26JUN2009 "RTN","MSCZJOB",2,0) ;;8.0;KERNEL;**MSC** "RTN","MSCZJOB",3,0) W !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! "RTN","MSCZJOB",4,0) N MSC "RTN","MSCZJOB",5,0) DDS ; "RTN","MSCZJOB",6,0) S DDSFILE=3.081,DR="[MSCZJOBEXAM]",DDSPARM="S" "RTN","MSCZJOB",7,0) D ^DDS Q "RTN","MSCZJOB",8,0) ; "RTN","MSCZJOB",9,0) UNLOCK(D0) ;FROM FIELD 2, PAGE 3: UNLOCK THE LOCK "RTN","MSCZJOB",10,0) N X,R,N S R=$G(@MSC@(MSCJOBID,"L",D0)) I R'["^" Q ;CAN'T SEE IT "RTN","MSCZJOB",11,0) S R=$P(R," ",2),X="L "_R D ^DIM Q:'$D(X) "RTN","MSCZJOB",12,0) S N=$$NSP(MSCJOBD0) "RTN","MSCZJOB",13,0) D UNLOCK^MSCZJOBU(R,N) "RTN","MSCZJOB",14,0) Q "RTN","MSCZJOB",15,0) ; "RTN","MSCZJOB",16,0) KILL(J) ;FROM FIELD "RTN","MSCZJOB",17,0) D KILL^MSCZJOBU(J) "RTN","MSCZJOB",18,0) Q "RTN","MSCZJOB",19,0) ; "RTN","MSCZJOB",20,0) COMPMUL ;COMPUTED MULTIPLE FOR MSCZJOBEXAM BLOCK "RTN","MSCZJOB",21,0) N X,D0,J "RTN","MSCZJOB",22,0) S MSC="^TMP(""MSCZJOB1"",$J)" D POLL "RTN","MSCZJOB",23,0) D JOBEXAM^MSCZJOBU(MSC) "RTN","MSCZJOB",24,0) F D0=0:0 S D0=$O(MSCZJOB(D0)) Q:'D0 D "RTN","MSCZJOB",25,0) .S MSCZJOB(D0)=MSCZJOB(D0)_U_$$DEV(D0)_U_$$USER(D0)_U_$$NSP(D0)_U_U_U_U_U_$$ROUTINE(D0) "RTN","MSCZJOB",26,0) .S X=MSCZJOB(D0) X DICMX "RTN","MSCZJOB",27,0) Q "RTN","MSCZJOB",28,0) JOB(D0) Q $P(MSCZJOB(D0),U) ;*** "RTN","MSCZJOB",29,0) DEV(D0) Q $$FIND(D0,"I","$PRINCIPAL") "RTN","MSCZJOB",30,0) NSP(D0) N N D Q N "RTN","MSCZJOB",31,0) .N L,P S N=$$FIND(D0,"I","$ZGBLDIR"),L=$L(N,"/") I L<2 Q "RTN","MSCZJOB",32,0) .F L=L-1:-1:2 S P=$P(N,"/",L) I P'[".",P'["globals" Q "RTN","MSCZJOB",33,0) .S P=1 I $P(N,"/")="" S P=2 "RTN","MSCZJOB",34,0) .S N=$P(N,"/",L) "RTN","MSCZJOB",35,0) USER(D0) Q $P($G(^VA(200,+$$FIND(D0,"V","DUZ"),0)),U) "RTN","MSCZJOB",36,0) ROUTINE(D0) Q $$FIND(D0,"V","%ZPOS") "RTN","MSCZJOB",37,0) ; "RTN","MSCZJOB",38,0) FIND(D0,ARR,KEY) N I,J,X S X="",J=+MSCZJOB(D0) "RTN","MSCZJOB",39,0) F I=0:0 S I=$O(@MSC@(J,ARR,I)) Q:'I I $P(^(I),KEY_"=")="" S X=$TR($P(^(I),"=",2),"""") Q "RTN","MSCZJOB",40,0) Q X "RTN","MSCZJOB",41,0) ; "RTN","MSCZJOB",42,0) COMPSTK ;COMPUTED MULTIPLE FOR MSCZJOBSTACK BLOCK "RTN","MSCZJOB",43,0) S MSC="^TMP(""MSCZJOB1"",$J)" K @MSC@(MSCJOBID) D POLL1 "RTN","MSCZJOB",44,0) D JOBEXAM^MSCZJOBU(MSC,MSCJOBID) "RTN","MSCZJOB",45,0) N D0,J S J=MSCJOBID "RTN","MSCZJOB",46,0) F D0=1:1:$O(@MSC@(J,"S",""),-1) S X="" X DICMX "RTN","MSCZJOB",47,0) Q "RTN","MSCZJOB",48,0) ; "RTN","MSCZJOB",49,0) STACK(D0) N X S X=$G(@MSC@(MSCJOBID,"S",D0)) "RTN","MSCZJOB",50,0) Q X "RTN","MSCZJOB",51,0) ; "RTN","MSCZJOB",52,0) COMPVARS ;COMPUTED MULTIPLE FOR MSCZJOBVARS BLOCK "RTN","MSCZJOB",53,0) S MSC="^TMP(""MSCZJOB1"",$J)" K @MSC@(MSCJOBID) D POLL1 "RTN","MSCZJOB",54,0) D JOBEXAM^MSCZJOBU(MSC,MSCJOBID) "RTN","MSCZJOB",55,0) N D0,J S J=MSCJOBID "RTN","MSCZJOB",56,0) F D0=1:1:$O(@MSC@(J,"V",""),-1) S X="" X DICMX "RTN","MSCZJOB",57,0) Q "RTN","MSCZJOB",58,0) ; "RTN","MSCZJOB",59,0) COMPLKS ;COMPUTED MULTIPLE FOR MSCZJOBLOCKS BLOCK "RTN","MSCZJOB",60,0) S MSC="^TMP(""MSCZJOB1"",$J)" D POLL1 "RTN","MSCZJOB",61,0) D JOBEXAM^MSCZJOBU(MSC,MSCJOBID) "RTN","MSCZJOB",62,0) N D0 "RTN","MSCZJOB",63,0) F D0=1:1:$$LOCKS S X="" X DICMX "RTN","MSCZJOB",64,0) Q "RTN","MSCZJOB",65,0) ; "RTN","MSCZJOB",66,0) LOCKS() Q +$O(@MSC@(MSCJOBID,"L",""),-1) "RTN","MSCZJOB",67,0) ; "RTN","MSCZJOB",68,0) POLL K MSCZJOB ;D HLP^DDSUTL(" POLLING JOBS.....") "RTN","MSCZJOB",69,0) I $G(^%ZOSF("OS"))["GT.M" D "RTN","MSCZJOB",70,0) .K @MSC "RTN","MSCZJOB",71,0) .D INTRPT^MSCZJOBU("*") ;SETS UP ^TMP "RTN","MSCZJOB",72,0) .N MSCA,I D PIDS^MSCZJOBU(.MSCA) "RTN","MSCZJOB",73,0) .S MSCA="" F I=1:1 S MSCA=$O(MSCA(MSCA)) Q:'MSCA S MSCZJOB(I)=MSCA ;SETS UP LOCAL ARRAY "RTN","MSCZJOB",74,0) .H 1 ;WAIT FOR POLLING "RTN","MSCZJOB",75,0) D TEST "RTN","MSCZJOB",76,0) Q "RTN","MSCZJOB",77,0) ; "RTN","MSCZJOB",78,0) POLL1 Q:'$G(MSCJOBID) "RTN","MSCZJOB",79,0) I $G(^%ZOSF("OS"))["GT.M" D "RTN","MSCZJOB",80,0) .K @MSC@(MSCJOBID) "RTN","MSCZJOB",81,0) .D INTRPT^MSCZJOBU(MSCJOBID) ;SETS UP ^TMP(MSCZJOB) "RTN","MSCZJOB",82,0) .H 1 ;WAIT FOR POLLING "RTN","MSCZJOB",83,0) D TEST "RTN","MSCZJOB",84,0) Q "RTN","MSCZJOB",85,0) ; "RTN","MSCZJOB",86,0) TEST Q "RTN","MSCZJOB",87,0) COMPLK ;COMPUTED MULTIPLE FOR MSCZLOCK BLOCK "RTN","MSCZJOB",88,0) N X,D0,J "RTN","MSCZJOB",89,0) S MSC="^TMP(""MSCZJOB1"",$J)" K @MSC D POLL,JOBEXAM^MSCZJOBU(MSC) S D0=0 "RTN","MSCZJOB",90,0) F K=0:0 S K=$O(MSCZJOB(K)) Q:'K D "RTN","MSCZJOB",91,0) .F J=0:0 S J=$O(^TMP("MSCZJOB1",$J,MSCZJOB(K),"L",J)) Q:'J S A=$TR(^(J),U,"~") D "RTN","MSCZJOB",92,0) ..S D0=D0+1,MSCZLK(D0)=$P(A,"LOCK ",2,9)_U_$$USER(K)_U_$TR($$ROUTINE(K),U,"~")_"^^"_MSCZJOB(K) "RTN","MSCZJOB",93,0) ..S X=MSCZLK(D0) X DICMX "RTN","MSCZJOB",94,0) Q "RTN","MSCZJOB",95,0) LOCK ; "RTN","MSCZJOB",96,0) S DDSFILE=3.081,DR="[MSCZLOCK]",DDSPARM="S" "RTN","MSCZJOB",97,0) D ^DDS Q "RTN","MSCZJOB",98,0) UNL(D0) ;FROM FIELD 2, PAGE 3: UNLOCK THE LOCK "RTN","MSCZJOB",99,0) N X,R,N S R=$P($G(MSCZLK(D0)),U),P=$P($G(MSCZLK(D0)),U,5) ;I R'["^" Q ;CAN'T SEE IT "RTN","MSCZJOB",100,0) S R=$P(R,"~",2),R="^"_$S(R'["(":$P(R," "),1:$P(R,")")_")"),X="L "_R D ^DIM Q:'$D(X) ;GOOD SYNTAX? "RTN","MSCZJOB",101,0) S N=$$NSP(D0) "RTN","MSCZJOB",102,0) D UNLOCK^MSCZJOBU(R,N) "RTN","MSCZJOBS") 0^46^B3805853 "RTN","MSCZJOBS",1,0) MSCZJOBS ;JKT/MSC - OpenVista System status ;26JUN2009 "RTN","MSCZJOBS",2,0) ;;8.0;KERNEL;**MSC** "RTN","MSCZJOBS",3,0) ; "RTN","MSCZJOBS",4,0) ALL D SS() Q "RTN","MSCZJOBS",5,0) THIS D SS(1) Q "RTN","MSCZJOBS",6,0) ; "RTN","MSCZJOBS",7,0) SS(THIS) ;Print GT.M mumps processes "RTN","MSCZJOBS",8,0) ; If THIS is true, only print processes associated with the current "RTN","MSCZJOBS",9,0) ; OpenVista instance "RTN","MSCZJOBS",10,0) ; "RTN","MSCZJOBS",11,0) Q:$G(^%ZOSF("OS"))'["GT.M" "RTN","MSCZJOBS",12,0) ; "RTN","MSCZJOBS",13,0) D INTRPT^MSCZJOBU("*") H .5 "RTN","MSCZJOBS",14,0) ; "RTN","MSCZJOBS",15,0) N DATETIME S DATETIME=$$HTE^XLFDT($H) "RTN","MSCZJOBS",16,0) W #!,?28,"OpenVista System Status" "RTN","MSCZJOBS",17,0) W !,?(40-($L(DATETIME)/2)\1),DATETIME "RTN","MSCZJOBS",18,0) W !!,?1,"Process",?12,"Device",?30,"Instance",?42,"Routine",?56,"User",?70,"Identity" "RTN","MSCZJOBS",19,0) ; "RTN","MSCZJOBS",20,0) N MSC S MSC="^TMP(""MSCZJOB1"",$J)" K @MSC "RTN","MSCZJOBS",21,0) D JOBEXAM^MSCZJOBU(MSC) "RTN","MSCZJOBS",22,0) N PID S PID="" "RTN","MSCZJOBS",23,0) F S PID=$O(@MSC@(PID)) Q:PID="" D "RTN","MSCZJOBS",24,0) . I $G(THIS) Q:$$INSTANCE(PID)'=$$CURRENT^ZCD() "RTN","MSCZJOBS",25,0) . W !,$$PID(PID) "RTN","MSCZJOBS",26,0) . W ?12,$$DEVICE(PID) "RTN","MSCZJOBS",27,0) . W ?30,$$INSTANCE(PID) "RTN","MSCZJOBS",28,0) . W ?42,$$ROUTINE(PID) "RTN","MSCZJOBS",29,0) . W ?56,$$USER(PID) "RTN","MSCZJOBS",30,0) . W ?70,$$IDENT(PID) "RTN","MSCZJOBS",31,0) K @MSC "RTN","MSCZJOBS",32,0) ; "RTN","MSCZJOBS",33,0) W !! ZSY "uptime" "RTN","MSCZJOBS",34,0) Q "RTN","MSCZJOBS",35,0) ; "RTN","MSCZJOBS",36,0) PID(PID) ;Return process ID formatted for display "RTN","MSCZJOBS",37,0) Q $J(PID,8)_$S($J=PID:"*",1:"") "RTN","MSCZJOBS",38,0) ; "RTN","MSCZJOBS",39,0) DEVICE(PID) ;Return device "RTN","MSCZJOBS",40,0) Q $$FIND(PID,"I","$PRINCIPAL") "RTN","MSCZJOBS",41,0) ; "RTN","MSCZJOBS",42,0) INSTANCE(PID) ;Return name of OpenVista instance "RTN","MSCZJOBS",43,0) N ZG S ZG=$$FIND(PID,"I","$ZGBLDIR") "RTN","MSCZJOBS",44,0) Q $P(ZG,"/",$L(ZG,"/")-2) "RTN","MSCZJOBS",45,0) ; "RTN","MSCZJOBS",46,0) ROUTINE(PID) ;Return routine "RTN","MSCZJOBS",47,0) Q $P($$FIND(PID,"V","%ZPOS"),"^",2) "RTN","MSCZJOBS",48,0) ; "RTN","MSCZJOBS",49,0) USER(PID) ;Return Linux user "RTN","MSCZJOBS",50,0) Q $$OWNER^MSCZJOBU(PID) "RTN","MSCZJOBS",51,0) ; "RTN","MSCZJOBS",52,0) IDENT(PID) ;Return OpenVista user "RTN","MSCZJOBS",53,0) N DUZ S DUZ=+$$FIND(PID,"V","DUZ") "RTN","MSCZJOBS",54,0) N ZG S ZG=$$FIND(PID,"I","$ZGBLDIR") "RTN","MSCZJOBS",55,0) Q $P($G(^|ZG|VA(200,DUZ,0)),"^") "RTN","MSCZJOBS",56,0) ; "RTN","MSCZJOBS",57,0) FIND(PID,ARR,KEY) ;Return the value of a key in one of the ZSHOW arrays "RTN","MSCZJOBS",58,0) N I,X S I="",X="" "RTN","MSCZJOBS",59,0) F S I=$O(@MSC@(PID,ARR,I)) Q:'I I $P(@MSC@(PID,ARR,I),KEY_"=")="" S X=$TR($P(@MSC@(PID,ARR,I),"=",2),"""") Q "RTN","MSCZJOBS",60,0) Q X "RTN","MSCZJOBU") 0^4^B7613711 "RTN","MSCZJOBU",1,0) MSCZJOBU ;RHL,JDS,JKT/MSC;26JUN2009 "RTN","MSCZJOBU",2,0) ;;8.0;KERNEL;**MSC** "RTN","MSCZJOBU",3,0) ; "RTN","MSCZJOBU",4,0) ; JOB EXAM UTILITIES FOR GT.M "RTN","MSCZJOBU",5,0) Q "RTN","MSCZJOBU",6,0) PIDS(XARY) ; GET ARRAY OF ALL MUMPS PROCESS "RTN","MSCZJOBU",7,0) ; XARY PASSED BY REFERENCE "RTN","MSCZJOBU",8,0) ; RETURNS XARY(PID)="" "RTN","MSCZJOBU",9,0) ; NOTE: Unix PID=$J for all mumps processes. "RTN","MSCZJOBU",10,0) ; "RTN","MSCZJOBU",11,0) N DEV "RTN","MSCZJOBU",12,0) S DEV="psdev" "RTN","MSCZJOBU",13,0) OPEN DEV:(COMM="ps -o pid= -C mumps":READONLY)::"PIPE" U DEV "RTN","MSCZJOBU",14,0) ; "RTN","MSCZJOBU",15,0) N %I S %I=$I "RTN","MSCZJOBU",16,0) N %J ; $JOB "RTN","MSCZJOBU",17,0) F U DEV R %J U %I Q:%J="" D "RTN","MSCZJOBU",18,0) . F Q:$E(%J,1)'=" " S %J=$E(%J,2,999) ; strip leading spaces "RTN","MSCZJOBU",19,0) . S XARY(%J)="" "RTN","MSCZJOBU",20,0) ; "RTN","MSCZJOBU",21,0) C DEV "RTN","MSCZJOBU",22,0) Q "RTN","MSCZJOBU",23,0) ; "RTN","MSCZJOBU",24,0) JOBEXAM(XARY,ONEPID) ; GET ARRAY OF JOB EXAM DATA FOR ALL MUMPS PROCESSES "RTN","MSCZJOBU",25,0) ; XARY is the name of a variable (or global) to merge job exam data into "RTN","MSCZJOBU",26,0) ; "RTN","MSCZJOBU",27,0) ; get a list of all OpenVista instances and look up their $ZG values "RTN","MSCZJOBU",28,0) N Y D LIST^ZCD "RTN","MSCZJOBU",29,0) N INSTANCE S INSTANCE="" "RTN","MSCZJOBU",30,0) F S INSTANCE=$O(Y("B",INSTANCE)) Q:INSTANCE="" D "RTN","MSCZJOBU",31,0) . N %ZG,%ZRO D NEWZGZRO^ZCD(INSTANCE) "RTN","MSCZJOBU",32,0) . S Y("B",INSTANCE)=%ZG "RTN","MSCZJOBU",33,0) ; "RTN","MSCZJOBU",34,0) I $G(ONEPID) D GETJOB(ONEPID) Q "RTN","MSCZJOBU",35,0) ; for each mumps process, search each OpenVista instance for the latest job exam data "RTN","MSCZJOBU",36,0) D PIDS(.XARY) ; XARY is doing double-duty; here it's an array "RTN","MSCZJOBU",37,0) N PID S PID="" "RTN","MSCZJOBU",38,0) F S PID=$O(XARY(PID)) Q:PID="" D GETJOB(PID) "RTN","MSCZJOBU",39,0) Q "RTN","MSCZJOBU",40,0) GETJOB(PID) ; "RTN","MSCZJOBU",41,0) N SORTDATE "RTN","MSCZJOBU",42,0) F S INSTANCE=$O(Y("B",INSTANCE)) Q:INSTANCE="" D "RTN","MSCZJOBU",43,0) . N H S H=$G(^|Y("B",INSTANCE)|TMP("MSCZJOB",PID,0)) Q:H="" "RTN","MSCZJOBU",44,0) . S SORTDATE($$SEC^XLFDT(H))=INSTANCE "RTN","MSCZJOBU",45,0) N MAXDATE S MAXDATE=$O(SORTDATE(""),-1) Q:MAXDATE="" "RTN","MSCZJOBU",46,0) M @XARY@(PID)=^|Y("B",SORTDATE(MAXDATE))|TMP("MSCZJOB",PID) "RTN","MSCZJOBU",47,0) Q "RTN","MSCZJOBU",48,0) ; "RTN","MSCZJOBU",49,0) OWNER(PID) ; get owner of process with PID "RTN","MSCZJOBU",50,0) N DEV "RTN","MSCZJOBU",51,0) S DEV="psdev" "RTN","MSCZJOBU",52,0) OPEN DEV:(COMM="ps -o user= -p "_PID:READONLY)::"PIPE" U DEV "RTN","MSCZJOBU",53,0) N UID R UID "RTN","MSCZJOBU",54,0) C DEV "RTN","MSCZJOBU",55,0) Q UID "RTN","MSCZJOBU",56,0) ; "RTN","MSCZJOBU",57,0) INTRPT(PID) ; SEND mupip intrpt to process with PID "RTN","MSCZJOBU",58,0) ; WHICH CAUSES THE $ZINTERRUPT CODE TO BE EXECUTED. "RTN","MSCZJOBU",59,0) ; PID PASSED BY VALUE "RTN","MSCZJOBU",60,0) ; PID CAN BE A SINGLE PID, I.E. $J "RTN","MSCZJOBU",61,0) ; PID CAN BE A "*" WHICH SENDS AN INTERRUPT TO ALL MUMPS PROCESSES "RTN","MSCZJOBU",62,0) ; "RTN","MSCZJOBU",63,0) Q:$G(PID)'?1N.N&($G(PID)'="*") "RTN","MSCZJOBU",64,0) ; "RTN","MSCZJOBU",65,0) N CMD,DEV "RTN","MSCZJOBU",66,0) S CMD="gtmsignal -q "_$S(PID="*":"-a",1:PID) "RTN","MSCZJOBU",67,0) S DEV="gtmsignaldev" "RTN","MSCZJOBU",68,0) OPEN DEV:(COMM=CMD:READONLY)::"PIPE" U DEV C DEV "RTN","MSCZJOBU",69,0) Q "RTN","MSCZJOBU",70,0) ; "RTN","MSCZJOBU",71,0) KILL(PID) ; Send mupip stop to process with PID "RTN","MSCZJOBU",72,0) ; PID PASSED BY VALUE "RTN","MSCZJOBU",73,0) ; PID CAN BE A SINGLE PID, I.E. $J "RTN","MSCZJOBU",74,0) ; "RTN","MSCZJOBU",75,0) Q:$G(PID)'?1N.N "RTN","MSCZJOBU",76,0) ; "RTN","MSCZJOBU",77,0) N DEV "RTN","MSCZJOBU",78,0) S DEV="gtmsignaldev" "RTN","MSCZJOBU",79,0) OPEN DEV:(COMM="gtmsignal -q -s "_PID:READONLY)::"PIPE" U DEV C DEV "RTN","MSCZJOBU",80,0) Q "RTN","MSCZJOBU",81,0) ; "RTN","MSCZJOBU",82,0) UNLOCK(NODE,INSTANCE) ; Use lke to remove lock on NODE. "RTN","MSCZJOBU",83,0) N %ZG,%ZRO "RTN","MSCZJOBU",84,0) D:$G(INSTANCE)'="" NEWZGZRO^ZCD(INSTANCE) "RTN","MSCZJOBU",85,0) N CMD,DEV "RTN","MSCZJOBU",86,0) S CMD="lke clear -lock="""_NODE_""" -nointeractive -output=/dev/null" "RTN","MSCZJOBU",87,0) S:$G(%ZG)'="" CMD="gtmgbldir="""_%ZG_""" "_CMD "RTN","MSCZJOBU",88,0) S DEV="lkedev" "RTN","MSCZJOBU",89,0) OPEN DEV:(SHELL="/bin/sh":COMM=CMD:READONLY)::"PIPE" U DEV C DEV "RTN","MSCZJOBU",90,0) Q "RTN","PRCSEA") 0^37^B66865498 "RTN","PRCSEA",1,0) PRCSEA ;WISC/SAW/DXH/BM/SC/DAP,MSC/JDA - CONTROL POINT ACTIVITY EDITS ;27APR2009 "RTN","PRCSEA",2,0) V ;;5.1;IFCAP;**81,MSC**;Oct 20, 2000 "RTN","PRCSEA",3,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","PRCSEA",4,0) ; "RTN","PRCSEA",5,0) ;PRC*5.1*81 BMM 3/23/05 when a 2237 is canceled, in CT1, add code "RTN","PRCSEA",6,0) ;to update Audit file (#414.02), and send update message to "RTN","PRCSEA",7,0) ;DynaMed thru a call to rtn PRCVTCA. "RTN","PRCSEA",8,0) ; "RTN","PRCSEA",9,0) ENRS ;ENTER REQ "RTN","PRCSEA",10,0) S PRCSK=1,X3="H" "RTN","PRCSEA",11,0) D EN1F^PRCSUT(1) ; ask site,FY,QRTR,CP & set up PRC array, PRCSIP variable ; prc*5*197 "RTN","PRCSEA",12,0) G W2:'$D(PRC("SITE")),EXIT:Y<0 ; unauthorized user or '^' entered "RTN","PRCSEA",13,0) D W6 ; display help on transaction# format "RTN","PRCSEA",14,0) ENRS0 S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="AELQ",D="H" "RTN","PRCSEA",15,0) S DIC("A")="Select TRANSACTION: " "RTN","PRCSEA",16,0) S DIC("S")="I '^(0),$P(^(0),U,3)'="""",$D(^PRCS(410,""H"",$P(^(0),U,3),+Y)),^(+Y)=DUZ!(^(+Y)="""")" ; only requests authored by user or unauthored will display on partial match "RTN","PRCSEA",17,0) D ^PRCSDIC ; lookup & preliminary validity checking "RTN","PRCSEA",18,0) K DLAYGO,DIC("A"),DIC("S") "RTN","PRCSEA",19,0) G:Y<0 EXIT "RTN","PRCSEA",20,0) I $P(Y,U,3)'=1 W $C(7)," Must be a new entry." G ENRS0 "RTN","PRCSEA",21,0) ;*81 Check site parameter to see if issue books are allowed "RTN","PRCSEA",22,0) D CKPRM^PRCSEB "RTN","PRCSEA",23,0) W !!,PRCVY,! "RTN","PRCSEA",24,0) S (PDA,T1,DA)=+Y "RTN","PRCSEA",25,0) L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...try a different transaction number or try later" G ENRS0 "RTN","PRCSEA",26,0) S T(2)=$P(Y,U,2) "RTN","PRCSEA",27,0) D EN2A^PRCSUT3 ; saves CP,sta,substa,txn name,user,BBFY,RB stat,acct data in new txn (nodes 0,3,6,11 of file 410) "RTN","PRCSEA",28,0) S $P(^PRCS(410,DA,14),"^")=DUZ ; originator (entered by) "RTN","PRCSEA",29,0) S $P(^PRCS(410,DA,7),"^")=DUZ,$P(^PRCS(410,DA,7),"^",2)=$P($G(^VA(200,DUZ,20)),"^",3) ; requestor default "RTN","PRCSEA",30,0) I $G(PRCSIP) S $P(^PRCS(410,DA,0),"^",6)=PRCSIP,^PRCS(410,"AO",PRCSIP,DA)="" ; PRCSIP was set up in PRCSUT & is inventory distribution point "RTN","PRCSEA",31,0) S PRCS="" ; set PRCS=1 if CP is automated, i.e. it uses IFCAP to send requests to A&MM "RTN","PRCSEA",32,0) I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS=1 "RTN","PRCSEA",33,0) TYPE ; "RTN","PRCSEA",34,0) W !!,"This transaction is assigned temporary transaction number: ",T(2) "RTN","PRCSEA",35,0) S DIC("A")="FORM TYPE: ",DIC="^PRCS(410.5,",DIC(0)="AEQZ" "RTN","PRCSEA",36,0) S DIC("S")=PRCVX ; only allow selection of 2237's "RTN","PRCSEA",37,0) D ^DIC "RTN","PRCSEA",38,0) S DA=PDA "RTN","PRCSEA",39,0) ;if user didn't enter a form type, go ask whether to backout and act "RTN","PRCSEA",40,0) ;accordingly: go let them re-enter a form type or exit "RTN","PRCSEA",41,0) I Y<0 G:'$$BACKOUT(T(2),DA) TYPE L -^PRCS(420,DA) G EXIT "RTN","PRCSEA",42,0) ; "RTN","PRCSEA",43,0) I Y<2 W "??" G TYPE "RTN","PRCSEA",44,0) K PRCVX,PRCVY "RTN","PRCSEA",45,0) S $P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y ; form type "RTN","PRCSEA",46,0) ; if CP is not automated (file 420), user's response will be overwritten with non-recuring (type 2). Although user's selection is changed 'behind the scenes', "RTN","PRCSEA",47,0) ; the scenario is unlikely to occur because full implementation of IFCAP was made mandatory and sites are now automated. "RTN","PRCSEA",48,0) S:'PRCS&(X>2) $P(^PRCS(410,DA,0),"^",4)=2,X=2 "RTN","PRCSEA",49,0) K PRCSERR ; flag denoting item info is missing "RTN","PRCSEA",50,0) S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410," "RTN","PRCSEA",51,0) S (PRCSDR,DR)="["_$S(X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]" "RTN","PRCSEA",52,0) EN1 K DTOUT,DUOUT,Y "RTN","PRCSEA",53,0) D ^DIE "RTN","PRCSEA",54,0) S DA=PDA "RTN","PRCSEA",55,0) I $D(Y)!($D(DTOUT)) D DOR L -^PRCS(410,DA) G EXIT "RTN","PRCSEA",56,0) D RL^PRCSUT1 ; sets up 'IT' & '10' nodes "RTN","PRCSEA",57,0) D ^PRCSCK I $D(PRCSERR),PRCSERR G EN1 ; missing required field ('item') "RTN","PRCSEA",58,0) D DOR ; populate date of request field if it is nil "RTN","PRCSEA",59,0) L -^PRCS(410,DA) "RTN","PRCSEA",60,0) S T="enter" D W5 G EXIT:%'=1 "RTN","PRCSEA",61,0) W !! K PRCS("SUB") "RTN","PRCSEA",62,0) G ENRS "RTN","PRCSEA",63,0) ; "RTN","PRCSEA",64,0) EDRS ;EDIT REQ "RTN","PRCSEA",65,0) ; following line commented out by PRC*5*140 - user responses not used to limit selection of txn and sometimes resulted in bad info being set into the selected txn "RTN","PRCSEA",66,0) ; S PRCSK=1 D EN1F^PRCSUT(1) G W2:'$D(PRC("SITE")),EXIT:Y<0 ; ask sta,FY,QRTR,CP ; prc*5*197 "RTN","PRCSEA",67,0) ; if the above line is reactivated, programmer should note that the transaction selected may not be of the same FY,QRTR,sta, subst, and CP specified by the user "RTN","PRCSEA",68,0) D W6 ; format doc for txn# "RTN","PRCSEA",69,0) S X3="H" S DIC="^PRCS(410,",DIC(0)="AEQ",D="H" "RTN","PRCSEA",70,0) S DIC("A")="Select TRANSACTION: " "RTN","PRCSEA",71,0) S DIC("S")="I '^(0),$P(^(0),U,3)'="""",$P(^(0),U,4)'=1,^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")" ; request must be authored by user or unauthored & cannot be a 1358 "RTN","PRCSEA",72,0) D ^PRCSDIC G EXIT:Y<0 K DIC("A"),DIC("S") "RTN","PRCSEA",73,0) S (PDA,DA,T1)=+Y "RTN","PRCSEA",74,0) L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G EDRS "RTN","PRCSEA",75,0) ; following line commented out in PRC*5*140 - PRCSUT3 needs PRC("SST") or MYY to do something, neither exists in this option "RTN","PRCSEA",76,0) ; D EN2B^PRCSUT3 "RTN","PRCSEA",77,0) S PRC("SITE")=+$P(^PRCS(410,PDA,0),"^",5) "RTN","PRCSEA",78,0) S PRC("CP")=$P(^PRCS(410,PDA,3),"^") "RTN","PRCSEA",79,0) I $P(^PRCS(410,PDA,0),"^",6)="" D ; prc*5*197 "RTN","PRCSEA",80,0) . N PRCSIP D IP^PRCSUT "RTN","PRCSEA",81,0) . I $D(PRCSIP) S $P(^PRC(410,DA,0),U,6)=PRCSIP "RTN","PRCSEA",82,0) S X=+$P(^PRCS(410,DA,0),"^",4) I X<1 D FORM "RTN","PRCSEA",83,0) ;*81 Check site parameter to see if Issue Books are allowed "RTN","PRCSEA",84,0) D CKPRM "RTN","PRCSEA",85,0) I PRCVD=1 S PRCVZ=1 "RTN","PRCSEA",86,0) I PRCVD'=1 S PRCVZ=0 "RTN","PRCSEA",87,0) W !,"The form type for this transaction is ",$P($G(^PRCS(410.5,X,0)),"^"),! "RTN","PRCSEA",88,0) I PRCVZ=1,X=5 W !,"All Supply Warehouse requests must be processed in the new Inventory System.",!!,"Please cancel this IFCAP issue book order." S T="edit" D W5 G:%'=1 EXIT W !! K PRCS("SUB") G EDRS "RTN","PRCSEA",89,0) ; "RTN","PRCSEA",90,0) S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410," "RTN","PRCSEA",91,0) ;P182--Modified next 3 lines to use new templates if supply fund FCP "RTN","PRCSEA",92,0) S (DR,PRCSDR)="["_$S(X=1:"PRCE NEW 1358S",X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]" "RTN","PRCSEA",93,0) ED1 K DTOUT,DUOUT,Y "RTN","PRCSEA",94,0) D ^DIE "RTN","PRCSEA",95,0) S DA=PDA "RTN","PRCSEA",96,0) I $D(Y)!($D(DTOUT)) L -^PRCS(410,DA) G EXIT "RTN","PRCSEA",97,0) D RL^PRCSUT1 "RTN","PRCSEA",98,0) D ^PRCSCK I $D(PRCSERR),PRCSERR G ED1 "RTN","PRCSEA",99,0) K PRCSERR S $P(^PRCS(410,DA,14),"^")=DUZ "RTN","PRCSEA",100,0) L -^PRCS(410,DA) "RTN","PRCSEA",101,0) S T="edit" D W5 G EXIT:%'=1 "RTN","PRCSEA",102,0) W !! K PRCS("SUB") "RTN","PRCSEA",103,0) G EDRS "RTN","PRCSEA",104,0) ; "RTN","PRCSEA",105,0) CT ;CANCEL A (PERMANENT) TRANS "RTN","PRCSEA",106,0) D EN3^PRCSUT "RTN","PRCSEA",107,0) G W2:'$D(PRC("SITE")),EXIT:Y<0 "RTN","PRCSEA",108,0) S DIC="^PRCS(410,",DIC(0)="AEMQ" "RTN","PRCSEA",109,0) ;S DIC("S")="I $P(^(0),""^"",4)=.5!($S('$D(^(7)):1,1:$P(^(7),""^"",6)="""")) I +^(0)>0,$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))" "RTN","PRCSEA",110,0) S DIC("S")="I $P(^(0),U,2)=""O""!($P(^(0),U,2)=""A""&($P(^(0),U,4)=1)),$S('$D(^(7)):1,1:$P(^(7),""^"",6)=""""),$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))" "RTN","PRCSEA",111,0) S DIC("A")="Select TRANSACTION: " "RTN","PRCSEA",112,0) D ^PRCSDIC G EXIT:Y<0 K DIC("S"),DIC("A") "RTN","PRCSEA",113,0) CT1 W !,"Cancel this transaction" S %=2 D YN^DICN G CT1:%=0,EXIT:%'=1 "RTN","PRCSEA",114,0) S DA=+Y "RTN","PRCSEA",115,0) L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G CT "RTN","PRCSEA",116,0) S T=$P(^PRCS(410,DA,0),"^"),$P(^(11),"^",3)="",$P(^(0),"^",2)="CA",$P(^(5),"^")=0,$P(^(6),"^")=0 "RTN","PRCSEA",117,0) K ^PRCS(410,"F",+T_"-"_+PRC("CP")_"-"_$P(T,"-",5),DA),^PRCS(410,"F1",$P(T,"-",5)_"-"_+T_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA) "RTN","PRCSEA",118,0) K ZX "RTN","PRCSEA",119,0) I $D(^PRCS(410,DA,4)) S ZX=^(4),X=$P(ZX,"^",8) F I=1,3,6,8 S $P(ZX,"^",I)=0 "RTN","PRCSEA",120,0) I $D(ZX) S ^PRCS(410,DA,4)=ZX K ZX "RTN","PRCSEA",121,0) I $D(^PRCS(410,DA,12,0)) S N=0 F I=0:0 S N=$O(^PRCS(410,DA,12,N)) Q:N'>0 S X=$P(^(N,0),"^",2) I X S DA(1)=DA,DA=N D TRANK^PRCSEZZ S DA=DA(1) "RTN","PRCSEA",122,0) D ERS410^PRC0G(DA_"^C") "RTN","PRCSEA",123,0) W !,"Enter comments for this cancellation",! "RTN","PRCSEA",124,0) S DIE=DIC,DR=60 "RTN","PRCSEA",125,0) D ^DIE "RTN","PRCSEA",126,0) ;PRC*5.1*81 if DM trx, update Audit file and send msg to DM "RTN","PRCSEA",127,0) D EN^PRCVTCA(DA) "RTN","PRCSEA",128,0) L -^PRCS(410,DA) "RTN","PRCSEA",129,0) I $D(^PRC(443,DA,0)) S DIK="^PRC(443," D ^DIK K DIK "RTN","PRCSEA",130,0) S T="cancel" D W4 G EXIT:%'=1 "RTN","PRCSEA",131,0) W !! G CT "RTN","PRCSEA",132,0) ; "RTN","PRCSEA",133,0) DT ;DELETE A (TEMPORARY) TRANS "RTN","PRCSEA",134,0) S X3="H" "RTN","PRCSEA",135,0) D W6 ; format doc for txn# "RTN","PRCSEA",136,0) S DIC="^PRCS(410,",DIC(0)="AEQ",DIC("A")="Select TRANSACTION: ",D="H" "RTN","PRCSEA",137,0) S DIC("S")="S W=$P(^(0),""^"",5),W(1)=+^(3) I '^(0),$P(^(0),""^"",3)'="""",^PRCS(410,""H"",$P(^(0),""^"",3),+Y)=DUZ!(^(+Y)="""")!($D(^PRC(420,""A"",DUZ,W,W(1),1)))!($D(^(2)))" "RTN","PRCSEA",138,0) D ^PRCSDIC G EXIT:Y<0 "RTN","PRCSEA",139,0) K DIC("S"),DIC("A") "RTN","PRCSEA",140,0) S DA=+Y "RTN","PRCSEA",141,0) L +^PRCS(410,DA):5 I $T=0 W !,"File is being accessed...please try later" G DT "RTN","PRCSEA",142,0) DT1 W !,"Delete this transaction" S %=2 D YN^DICN G DT1:%=0,EXIT:%'=1 "RTN","PRCSEA",143,0) ;The following line was commented out in patch 182; should NOT manually "RTN","PRCSEA",144,0) ;change or reset last assigned IEN # in node zero. "RTN","PRCSEA",145,0) ;S PRCSDA=$P(^PRCS(410,0),U,3),DIK=DIC "RTN","PRCSEA",146,0) S DIK=DIC "RTN","PRCSEA",147,0) W !,"Okay....." "RTN","PRCSEA",148,0) D ^DIK K DIK "RTN","PRCSEA",149,0) L -^PRCS(410,DA) "RTN","PRCSEA",150,0) ;The following line was commented out in patch 182; should NOT manually "RTN","PRCSEA",151,0) ;change or reset last assigned IEN # in node zero. "RTN","PRCSEA",152,0) ;S $P(^PRCS(410,0),U,3)=PRCSDA "RTN","PRCSEA",153,0) K PRCSDA "RTN","PRCSEA",154,0) W "It's deleted" "RTN","PRCSEA",155,0) S T="delete" D W4 G EXIT:%'=1 "RTN","PRCSEA",156,0) W !! G DT "RTN","PRCSEA",157,0) ; "RTN","PRCSEA",158,0) ; "RTN","PRCSEA",159,0) DOR ; Date of Request "RTN","PRCSEA",160,0) I $D(^PRCS(410,DA,1)),$P(^PRCS(410,DA,1),"^")'="" Q "RTN","PRCSEA",161,0) S %DT="X",X="T" D ^%DT S $P(^PRCS(410,DA,1),"^")=Y "RTN","PRCSEA",162,0) Q "RTN","PRCSEA",163,0) FORM ;*81 Allow user to change txn to a valid form and check site parameter to see if issue books are allowed "RTN","PRCSEA",164,0) D CKPRM "RTN","PRCSEA",165,0) I PRCVD=1 S PRCVX1="I Y>1&(Y<5)",PRCVY1="The Issue Book and NO FORM type are not valid in this option." "RTN","PRCSEA",166,0) I PRCVD'=1 S PRCVX1="I Y>1",PRCVY1="The NO FORM type is not valid in this option." "RTN","PRCSEA",167,0) W !,PRCVY1,! "RTN","PRCSEA",168,0) W !,"Please enter another form type",! "RTN","PRCSEA",169,0) S PRCSDAA=DA,DIC="^PRCS(410.5,",DIC("A")="FORM TYPE: ",DIC(0)="AEQZ" "RTN","PRCSEA",170,0) S DIC("S")=PRCVX1 "RTN","PRCSEA",171,0) D ^DIC "RTN","PRCSEA",172,0) S:Y=-1 Y=2 "RTN","PRCSEA",173,0) S DA=PRCSDAA,$P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y "RTN","PRCSEA",174,0) K DIC,PRCVX1,PRCVY1,PRCVD "RTN","PRCSEA",175,0) Q "RTN","PRCSEA",176,0) ; "RTN","PRCSEA",177,0) ;Allow user the option of re entering a form type. If they decline, "RTN","PRCSEA",178,0) ;kill off the transaction and return 1; else return 0 "RTN","PRCSEA",179,0) BACKOUT(TRNNAME,TRNDA) ; "RTN","PRCSEA",180,0) N DIK,Y,%,DA "RTN","PRCSEA",181,0) F D Q:%'=0 "RTN","PRCSEA",182,0) . W !!,"WARNING: WITHOUT A FORM TYPE, TRANSACTION """,TRNNAME,""" WILL BE DELETED!",$C(7) "RTN","PRCSEA",183,0) . W !,"Are you sure you want to delete this transaction" S %=2 D YN^DICN "RTN","PRCSEA",184,0) . Q "RTN","PRCSEA",185,0) I %=2 Q 0 "RTN","PRCSEA",186,0) S DIK="^PRCS(410,",DA=TRNDA "RTN","PRCSEA",187,0) D ^DIK "RTN","PRCSEA",188,0) Q 1 "RTN","PRCSEA",189,0) ; "RTN","PRCSEA",190,0) W2 W !!,"You are not an authorized control point user.",!,"Contact control point official" R X:5 G EXIT "RTN","PRCSEA",191,0) W3 Q ; can this subroutine be deleted? commented out in patch PRC*5*140 "RTN","PRCSEA",192,0) W !!,"This transaction is assigned temporary transaction number: ",X Q "RTN","PRCSEA",193,0) W4 W !!,"Would you like to ",T," another transaction" S %=2 D YN^DICN G W4:%=0 Q "RTN","PRCSEA",194,0) W5 W !!,"Would you like to ",T," another request" S %=1 D YN^DICN G W5:%=0 Q "RTN","PRCSEA",195,0) W6 W !!,"For the transaction number, use an uppercase alpha as the first character,",!," and then 2-15 alphanumerics, as in 'ADP1'.",! Q "RTN","PRCSEA",196,0) ;*81 Site parameter pull "RTN","PRCSEA",197,0) CKPRM S PRCVD=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q") "RTN","PRCSEA",198,0) Q "RTN","PRCSEA",199,0) ; "RTN","PRCSEA",200,0) EXIT K %,C,D,DA,DIC,DIE,DR,PRCS,PDA,PRCSL,T,X,Y,Z,T1,X3,TYPE,PRCVZ "RTN","PRCSEA",201,0) I $D(PRCSERR) K PRCSERR "RTN","PRCSEA",202,0) Q "RTN","PSBOMH1") 0^38^B71152392 "RTN","PSBOMH1",1,0) PSBOMH1 ;BIRMINGHAM/EFC,MSC/JDA - MAH ;27APR2009 "RTN","PSBOMH1",2,0) ;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,MSC**;Mar 2004 "RTN","PSBOMH1",3,0) ; "RTN","PSBOMH1",4,0) ; Reference/IA "RTN","PSBOMH1",5,0) ; ^DILF/2054 "RTN","PSBOMH1",6,0) ; File 200/10060 "RTN","PSBOMH1",7,0) ; "RTN","PSBOMH1",8,0) EN ; "RTN","PSBOMH1",9,0) ; Load administrations "RTN","PSBOMH1",10,0) S (PSBORD,PSBIEN,PSBR1,PSBADIEN,PSBABR)="",PSBDT=PSBSTRT "RTN","PSBOMH1",11,0) K PSBTSA "RTN","PSBOMH1",12,0) F S PSBDT=$O(^PSB(53.79,"AADT",DFN,PSBDT)) Q:'PSBDT!(PSBDT>PSBSTOP) D "RTN","PSBOMH1",13,0) .F S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBDT,PSBIEN)) Q:'PSBIEN Q:'$D(^PSB(53.79,PSBIEN)) L +^PSB(53.79,PSBIEN):3 I $P(^PSB(53.79,PSBIEN,0),U,9)]"" D L -^PSB(53.79,PSBIEN) "RTN","PSBOMH1",14,0) ..Q:'$P($G(^PSB(53.79,PSBIEN,0)),U,6) ; Bad IEN -no evnt dt "RTN","PSBOMH1",15,0) ..Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N" ;NGiven "RTN","PSBOMH1",16,0) ..S PSBORD=$P($G(^PSB(53.79,PSBIEN,.1)),U,1) "RTN","PSBOMH1",17,0) ..; Continuous "RTN","PSBOMH1",18,0) ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="C" "RTN","PSBOMH1",19,0) ...S X=PSBDT D H^%DTC S PSBWEEK=PSBAR(%H) D CLEAN^PSBVT,PSJ1^PSBVT($P(^PSB(53.79,PSBIEN,0),U,1),$P(^PSB(53.79,PSBIEN,.1),U,1)) "RTN","PSBOMH1",20,0) ...I $P(^PSB(53.79,PSBIEN,0),U,6)'=PSBDT,'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBMR) D D CLEAN^PSBVT Q ;chck IV audit "RTN","PSBOMH1",21,0) ....S PSBSIEN=PSBIEN "RTN","PSBOMH1",22,0) ....I $P(^PSB(53.79,PSBIEN,0),"^",10)]"" D BAGDTL^PSBRPC2(.PSBAUD,$P(^PSB(53.79,PSBIEN,0),U,10),$P(^PSB(53.79,PSBIEN,.1),U,1)) "RTN","PSBOMH1",23,0) ....S PSBIEN=PSBSIEN K PSBSIEN "RTN","PSBOMH1",24,0) ....S X=0 F S X=$O(PSBAUD(X)) Q:X="" I $P(PSBAUD(X),U,3)="" K PSBAUD(X) "RTN","PSBOMH1",25,0) ....S X=0 F S X=$O(PSBAUD(X)) Q:X="" Q:$P(PSBAUD(X),U,1)=PSBDT "RTN","PSBOMH1",26,0) ....I X="" K PSBAUD Q "RTN","PSBOMH1",27,0) ....I '$D(PSBAUD(X)) K PSBAUD Q "RTN","PSBOMH1",28,0) ....S PSBS=$P(PSBAUD(X),U,3) "RTN","PSBOMH1",29,0) ....I PSBS="GIVEN",$P($G(PSBAUD(X-1)),U,3)="NOT GIVEN" Q "RTN","PSBOMH1",30,0) ....I PSBS="NOT GIVEN" Q "RTN","PSBOMH1",31,0) ....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NOACTION") "RTN","PSBOMH1",32,0) ....D PSBSTIV^PSBOMH2 "RTN","PSBOMH1",33,0) ....S X=PSBDT_U_$P(PSBAUD(X),U,2)_U_PSBS_U_PSBIEN "RTN","PSBOMH1",34,0) ....S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1 "RTN","PSBOMH1",35,0) ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X "RTN","PSBOMH1",36,0) ....S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y "RTN","PSBOMH1",37,0) ....D PSBOUT($P((X),"^",1),$P((X),"^",2)) "RTN","PSBOMH1",38,0) ....K PSBAUD "RTN","PSBOMH1",39,0) ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL") "RTN","PSBOMH1",40,0) ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME") "RTN","PSBOMH1",41,0) ...I PSBINIT="" S PSBINIT=99 "RTN","PSBOMH1",42,0) ...;get instrc info - audt log "RTN","PSBOMH1",43,0) ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D "RTN","PSBOMH1",44,0) ....D INSTR^PSBOMH "RTN","PSBOMH1",45,0) ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="" "RTN","PSBOMH1",46,0) ...I PSBINIT[99 S PSBINIT="" "RTN","PSBOMH1",47,0) ...I $P(^PSB(53.79,PSBIEN,0),U,9)="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("A") "RTN","PSBOMH1",48,0) ...I $P(^PSB(53.79,PSBIEN,0),U,9)'="G",PSBDT=$P(^PSB(53.79,PSBIEN,0),U,6) D PSBCK1^PSBOMH2("B") "RTN","PSBOMH1",49,0) ...I PSBDT'=$P(^PSB(53.79,PSBIEN,0),U,6),$P(^PSB(53.79,PSBIEN,0),U,9)="RM" D "RTN","PSBOMH1",50,0) ....D DDAUD "RTN","PSBOMH1",51,0) ....S I="" F S I=$O(PSBTAR(I),-1) Q:I="" I $P(PSBTAR(I),U,1)=PSBDT D "RTN","PSBOMH1",52,0) .....S PSBS=$P(PSBTAR(I),U,3) "RTN","PSBOMH1",53,0) .....I PSBS="GIVEN",$P($G(PSBTAR(I-1)),U,3)="NOT GIVEN" Q ; canceled - not given "RTN","PSBOMH1",54,0) .....I PSBS="NOT GIVEN" Q "RTN","PSBOMH1",55,0) .....S PSBS=$S(PSBS="INFUSING":"I",PSBS="GIVEN":"G",PSBS="COMPLETED":"C",PSBS="HELD":"H",PSBS="REFUSED":"R",PSBS="REMOVED":"RM",PSBS="STOPPED":"S",PSBS["MISSING":"M",1:"NO ACTION") "RTN","PSBOMH1",56,0) .....D PSBCTAR^PSBOMH2 "RTN","PSBOMH1",57,0) .....S X=$P(PSBTAR(I),U,1,2)_U_PSBS_U_PSBIEN "RTN","PSBOMH1",58,0) ...S Y=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,""),-1)+1 "RTN","PSBOMH1",59,0) ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,Y)=X "RTN","PSBOMH1",60,0) ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDT\1,0)=Y "RTN","PSBOMH1",61,0) ...D PSBOUT($P((X),"^",1),$P((X),"^",2)) "RTN","PSBOMH1",62,0) ...Q "RTN","PSBOMH1",63,0) ..; 1-Time On Call or PRN "RTN","PSBOMH1",64,0) ..D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)'="C" "RTN","PSBOMH1",65,0) ...I PSBDT'=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I") Q "RTN","PSBOMH1",66,0) ...S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL") "RTN","PSBOMH1",67,0) ...S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME") "RTN","PSBOMH1",68,0) ...I PSBINIT="" S PSBINIT=99 "RTN","PSBOMH1",69,0) ...S (PSBXA,PSBM)=1,(PSBZ,PSBT,PSBFLG)="" "RTN","PSBOMH1",70,0) ...I $$GET1^DIQ(53.79,PSBIEN_",",.09)="REMOVED" D "RTN","PSBOMH1",71,0) ....F I=1:1 S PSBXA=$O(^PSB(53.79,PSBIEN,.9,PSBXA)) Q:PSBXA="" I PSBXA?1.3N S PSBZ=PSBZ+1,PSBT(PSBZ)=^PSB(53.79,PSBIEN,.9,PSBXA,0) "RTN","PSBOMH1",72,0) ....F S=1:1 Q:PSBM<1 S PSBM=PSBZ-S I (PSBM>0) I (PSBT(PSBM)["GIVEN") S PSBFLG="1" S PRELINE1=$P(PSBT(PSBM),"'",2)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.04)_" "_$E($P(PSBT(PSBM),"'",4),1,3) Q "RTN","PSBOMH1",73,0) ...I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D "RTN","PSBOMH1",74,0) ....D INSTR^PSBOMH "RTN","PSBOMH1",75,0) ....S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="" "RTN","PSBOMH1",76,0) ...I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D PSBOUT(PSBDT,PSBINIT) "RTN","PSBOMH1",77,0) ...S PSBLINE1=$$GET1^DIQ(53.79,PSBIEN_",",.09)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.06)_" "_PSBINIT_" "_$$GET1^DIQ(53.79,PSBIEN_",",.21),PSBLINE2="" "RTN","PSBOMH1",78,0) ...I PSBINIT[99 S PSBINIT="" "RTN","PSBOMH1",79,0) ...D:$P($G(^PSB(53.79,PSBIEN,.1)),U,2)="P" "RTN","PSBOMH1",80,0) ....I $P($G(^PSB(53.79,PSBIEN,.2)),U,2)="" S PSBLINE2=" Results: " "RTN","PSBOMH1",81,0) ....E D "RTN","PSBOMH1",82,0) .....S PSBINIT=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:INITIAL") "RTN","PSBOMH1",83,0) .....S PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","PRN EFFECTIVENESS ENTERED BY:NAME") "RTN","PSBOMH1",84,0) .....I PSBINIT="" S PSBINIT=99 "RTN","PSBOMH1",85,0) .....I $D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D "RTN","PSBOMH1",86,0) ......S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."),0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24) "RTN","PSBOMH1",87,0) ......S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="" "RTN","PSBOMH1",88,0) .....I '$D(^PSB(53.79,PSBIEN,.9,$P(PSBDT,"."))) D "RTN","PSBOMH1",89,0) ......D:$D(^PSB(53.79,PSBIEN,.9,0)) "RTN","PSBOMH1",90,0) .......S (PSBXA2,PSBFG)=0,PSBEFFDT=$P(^PSB(53.79,PSBIEN,.2),U,4) F S PSBXA2=$O(^PSB(53.79,PSBIEN,.9,PSBXA2)) Q:+PSBXA2'>0 D Q:PSBFG=1 "RTN","PSBOMH1",91,0) ........D:($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U)=PSBEFFDT)&($P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)["Instruct")&($P(^PSB(53.79,PSBIEN,.2),U,3)=$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,2)) "RTN","PSBOMH1",92,0) .........S PSBINIT=PSBINIT_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA2,0),U,3)_" "_$$GET1^DIQ(53.79,PSBIEN_",",.24) "RTN","PSBOMH1",93,0) .........S ^TMP("PSB",$J,"LEGEND",PSBINIT,PSBNAME)="",PSBFG=1 "RTN","PSBOMH1",94,0) .....S PSBLINE2=" Results: "_$$GET1^DIQ(53.79,PSBIEN_",",.22) "RTN","PSBOMH1",95,0) .....S PSBRTXTW=" Entered By "_PSBINIT_" on "_$$GET1^DIQ(53.79,PSBIEN_",",.24) "RTN","PSBOMH1",96,0) .....I PSBINIT[99 S PSBINIT="" "RTN","PSBOMH1",97,0) ...S X=PSBDT D H^%DTC F PSBWEEK=PSBAR(%H):-7 Q:$D(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",0))!('$D(PSBAR(PSBWEEK))) "RTN","PSBOMH1",98,0) ...S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)+1 "RTN","PSBOMH1",99,0) ...I PSBFLG="1" S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X)=PRELINE1 "RTN","PSBOMH1",100,0) ...S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+1)=PSBLINE1 "RTN","PSBOMH1",101,0) ...I $G(PSBLINE2)]"" D "RTN","PSBOMH1",102,0) ....I $L(PSBLINE2)<90 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=PSBLINE2 S:$$GET1^DIQ(53.79,PSBIEN_",",.24)'="" ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_PSBRTXTW "RTN","PSBOMH1",103,0) ....I $L(PSBLINE2)>90 D "RTN","PSBOMH1",104,0) .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+2)=$E(PSBLINE2,1,90) "RTN","PSBOMH1",105,0) .....S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+3)=" "_$E(PSBLINE2,91,161) "RTN","PSBOMH1",106,0) .....I $L(PSBLINE2)'>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_PSBRTXTW "RTN","PSBOMH1",107,0) .....I $L(PSBLINE2)>161 S ^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+4)=" "_$E(PSBLINE2,162,200),^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",X+5)=" "_PSBRTXTW "RTN","PSBOMH1",108,0) Q "RTN","PSBOMH1",109,0) ; "RTN","PSBOMH1",110,0) DDAUD ; audits for dispen drugs "RTN","PSBOMH1",111,0) ; "RTN","PSBOMH1",112,0) M PSBMLA=^PSB(53.79,PSBIEN) "RTN","PSBOMH1",113,0) S PSBGA="" I $D(PSBMLA(.9,0)) D "RTN","PSBOMH1",114,0) .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q "RTN","PSBOMH1",115,0) ..I $D(PSBMLA(.9,PSBX-2,0)) D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE) "RTN","PSBOMH1",116,0) ..I '$D(PSBMLA(.9,PSBX-2,0)) S PSBDATE=$P(^PSB(53.79,PSBIEN,0),U,6) "RTN","PSBOMH1",117,0) ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2) "RTN","PSBOMH1",118,0) ..S PSBGA=1 "RTN","PSBOMH1",119,0) .F PSBX=1:1 Q:'$D(PSBMLA(.9,PSBX)) I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D "RTN","PSBOMH1",120,0) ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL^PSBRPC2($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2) "RTN","PSBOMH1",121,0) ..S PSBGA=1 "RTN","PSBOMH1",122,0) I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,7)) "RTN","PSBOMH1",123,0) S PSBQRY="PSBTMP",PSBCNT=1 F S PSBPQRY=PSBQRY S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action "RTN","PSBOMH1",124,0) .I PSBPQRY="PSBTMP" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no prev action "RTN","PSBOMH1",125,0) .I $QS(PSBPQRY,2)="C" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; prev line = comment "RTN","PSBOMH1",126,0) .I $QS(PSBQRY,2)="C",$E($P(@PSBPQRY,U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@PSBPQRY,U,2)=$P(@PSBQRY,U,2) D Q "RTN","PSBOMH1",127,0) ..S X=$P(@PSBQRY,U,4) S:X[":" X=$P(X,":",2) S $P(PSBTAR(PSBCNT-1),U,4)=X Q "RTN","PSBOMH1",128,0) .S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 "RTN","PSBOMH1",129,0) Q "RTN","PSBOMH1",130,0) ; "RTN","PSBOMH1",131,0) PSBOUT(PSBTET,PSBOT1) ; "RTN","PSBOMH1",132,0) I '$D(^PSB(53.79,PSBIEN,.9,0)) D PSBENT^PSBOMH2(PSBOT1) "RTN","PSBOMH1",133,0) S PSBIDA="" I $P(^PSB(53.79,PSBIEN,0),U,6)=PSBTET S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,7),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1) "RTN","PSBOMH1",134,0) S PSBXA1=0 "RTN","PSBOMH1",135,0) F S PSBXA1=$O(^PSB(53.79,PSBIEN,.9,PSBXA1)) Q:+PSBXA1'>0 I PSBXA1'=0 D Q:$G(PSBOT1)["*" "RTN","PSBOMH1",136,0) .I $L(PSBXA1)<4 D "RTN","PSBOMH1",137,0) ..I $P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1)=PSBTET D "RTN","PSBOMH1",138,0) ...S:$G(PSBIDA)="" PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1) "RTN","PSBOMH1",139,0) ...I (PSBIDA=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",2)),$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",3)["Instruct" D "RTN","PSBOMH1",140,0) ....S INSDD=$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),"^",1),Y=INSDD D DD^%DT S INSDD=Y "RTN","PSBOMH1",141,0) ....S PSBOT1=PSBOT1_"*",PSBNAME=PSBNAME_"/"_$P(^PSB(53.79,PSBIEN,.9,PSBXA1,0),U,3)_" "_INSDD "RTN","PSBOMH1",142,0) I $G(PSBIDA)="",$P(^PSB(53.79,PSBIEN,0),U,4)=PSBTET D "RTN","PSBOMH1",143,0) .S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1) "RTN","PSBOMH1",144,0) I $G(PSBNAME)="" D "RTN","PSBOMH1",145,0) . S PSBIDA=$P(^PSB(53.79,PSBIEN,0),U,5),PSBOT1=$P(^VA(200,PSBIDA,0),"^",2),PSBNAME=$P(^VA(200,PSBIDA,0),"^",1) "RTN","PSBOMH1",146,0) I $G(PSBOT1)]""&($G(PSBNAME)]"") S ^TMP("PSB",$J,"LEGEND",PSBOT1,PSBNAME)="" ;MSC "RTN","PSBOMH1",147,0) Q "RTN","PSBOMH1",148,0) ; "RTN","PSBRPC2") 0^39^B44967923 "RTN","PSBRPC2",1,0) PSBRPC2 ;BIRMINGHAM/EFC,MSC/JDA - BCMA RPC BROKER CALLS ;27APR2009 "RTN","PSBRPC2",2,0) ;;3.0;BAR CODE MED ADMIN;**6,3,16,MSC**;Mar 2004 "RTN","PSBRPC2",3,0) ; "RTN","PSBRPC2",4,0) ; Reference/IA "RTN","PSBRPC2",5,0) ; File 50/221 "RTN","PSBRPC2",6,0) ; File 52.6/436 "RTN","PSBRPC2",7,0) ; File 52.7/437 "RTN","PSBRPC2",8,0) ; File 200/10060 "RTN","PSBRPC2",9,0) ; "RTN","PSBRPC2",10,0) GETOHIST(RESULTS,DFN,PSBORD) ; "RTN","PSBRPC2",11,0) S RESULTS=$NAME(^TMP("PSB",$J)),PSB=0 "RTN","PSBRPC2",12,0) S ^TMP("PSB",$J,0)=1,^TMP("PSB",$J,1)="-1^No History On File" "RTN","PSBRPC2",13,0) D NOW^%DTC S PSBNOW=$P(%,".",1),PSBNOWZ=% "RTN","PSBRPC2",14,0) D EN^PSBPOIV(DFN,PSBORD) "RTN","PSBRPC2",15,0) S PSBUID=DFN_"V"_99999 F S PSBUID=$O(^TMP("PSBAR",$J,PSBUID),-1) Q:PSBUID="" D "RTN","PSBRPC2",16,0) .S PSBUIDS=^TMP("PSBAR",$J,PSBUID) "RTN","PSBRPC2",17,0) .I ((PSBOSTS="D")!(PSBOSTS="E")),$P(PSBUIDS,U,2)'="I",$P(PSBUIDS,U,2)'="S" Q ; only want the infusing bag on a dc'ed order "RTN","PSBRPC2",18,0) .I (PSBOSTS="A"),(PSBOSP0 S RESULTS(0)=1,RESULTS(1)="-1^No History On File" Q "RTN","PSBRPC2",60,0) M PSBMLA=^PSB(53.79,PSBIEN) "RTN","PSBRPC2",61,0) S X=$P(^PSB(53.79,PSBIEN,0),U,9) "RTN","PSBRPC2",62,0) S PSBLAC=$S(X="I":"INFUSING",X="G":"GIVEN",X="C":"COMPLETE",X="H":"HELD",X="R":"REFUSED",X="RM":"REMOVED",X="S":"STOPPED",X="M":"MISSING",1:"NO ACTION") "RTN","PSBRPC2",63,0) ; comments "RTN","PSBRPC2",64,0) S PSBX="0" F S PSBX=$O(PSBMLA(.3,PSBX)) Q:PSBX="" S PSBTMP(10000000-$P(PSBMLA(.3,PSBX,0),U,3),"C")=$P(PSBMLA(.3,PSBX,0),U,3)_U_$$INITIAL($P(PSBMLA(.3,PSBX,0),U,2))_U_U_$P(PSBMLA(.3,PSBX,0),U,1) "RTN","PSBRPC2",65,0) ; audit "RTN","PSBRPC2",66,0) S PSBGA="" I $D(PSBMLA(.9,0)) D "RTN","PSBRPC2",67,0) .S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D Q "RTN","PSBRPC2",68,0) ..S PSBDATE=$P(PSBMLA(0),U,4) I (PSBX-2)>0 D DT^DILF("ENPST",$P(PSBMLA(.9,PSBX-2,0),"'",2),.PSBDATE) "RTN","PSBRPC2",69,0) ..S PSBTMP(10000000-PSBDATE,"B")=PSBDATE_U_$$INITIAL($P(PSBMLA(0),U,5))_U_$P(PSBMLA(.9,PSBX,0),"'",2) "RTN","PSBRPC2",70,0) ..S PSBGA=1 "RTN","PSBRPC2",71,0) .S PSBX="0" F S PSBX=$O(PSBMLA(.9,PSBX)) Q:PSBX="" I ((PSBMLA(.9,PSBX,0)["ACTION STATUS")!(PSBMLA(.9,PSBX,0)["ADMINISTRATION STATUS")) D "RTN","PSBRPC2",72,0) ..S PSBTMP(10000000-$P(PSBMLA(.9,PSBX,0),U,1),"B")=$P(PSBMLA(.9,PSBX,0),U,1)_U_$$INITIAL($P(PSBMLA(.9,PSBX,0),U,2))_U_$P($P(PSBMLA(.9,PSBX,0),U,3),"'",2) "RTN","PSBRPC2",73,0) ..S PSBGA=1 "RTN","PSBRPC2",74,0) I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL($P(PSBMLA(0),U,7))_U_PSBLAC "RTN","PSBRPC2",75,0) S PSBQRY="PSBTMP",PSBCNT=1 F S PSBPQRY=PSBQRY S PSBQRY=$Q(@PSBQRY) Q:PSBQRY="" D ; does comment go with action "RTN","PSBRPC2",76,0) .I PSBPQRY="PSBTMP" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; no previous action "RTN","PSBRPC2",77,0) .I $QS(PSBPQRY,2)="C" S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q ; previous line is a comment "RTN","PSBRPC2",78,0) .I $QS(PSBQRY,2)="C",$E($P(@PSBPQRY,U,1),1,12)=$E($P(@PSBQRY,U,1),1,12),$P(@PSBPQRY,U,2)=$P(@PSBQRY,U,2) S X=$P(@PSBQRY,U,4),$P(RESULTS(PSBCNT-1),U,4)=X Q "RTN","PSBRPC2",79,0) .S RESULTS(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 "RTN","PSBRPC2",80,0) S RESULTS(0)=PSBCNT-1 "RTN","PSBRPC2",81,0) K PSBMLA,PSBIEN,PSBTMP,PSBQRY "RTN","PSBRPC2",82,0) Q "RTN","PSBRPC2",83,0) ; "RTN","PSBRPC2",84,0) INITIAL(PSBDUZ) ; "RTN","PSBRPC2",85,0) Q $$GET1^DIQ(200,PSBDUZ,"INITIAL") "RTN","PSBRPC2",86,0) SCANMED(RESULTS,PSBDIEN,PSBTAB) ; Lookup Medication "RTN","PSBRPC2",87,0) ; "RTN","PSBRPC2",88,0) ; RPC: PSB SCANMED "RTN","PSBRPC2",89,0) ; "RTN","PSBRPC2",90,0) ; Description: "RTN","PSBRPC2",91,0) ; Does a lookup on file 50 returns -1 on invalid lookup or "RTN","PSBRPC2",92,0) ; IEN^DrugName on success "RTN","PSBRPC2",93,0) ; "RTN","PSBRPC2",94,0) D NOW^%DTC S PSBDT=% "RTN","PSBRPC2",95,0) S PSBCNT=0 "RTN","PSBRPC2",96,0) I $L(PSBDIEN)>40 S PSBDIEN=$E(PSBDIEN,1,40) "RTN","PSBRPC2",97,0) S RESULTS(PSBCNT)=1 "RTN","PSBRPC2",98,0) S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)="-1^Invalid Medication Lookup" "RTN","PSBRPC2",99,0) I $$GET^XPAR("DIV","PSB ROBOT RX"),PSBDIEN?1"3"15N!(PSBDIEN?1"3"17N),123[$E(PSBDIEN,12) S PSBDIEN=$E(PSBDIEN,2,11) "RTN","PSBRPC2",100,0) I PSBTAB="UDTAB" D Q "RTN","PSBRPC2",101,0) .S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") "RTN","PSBRPC2",102,0) .I X<1 Q "RTN","PSBRPC2",103,0) .E S RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01) "RTN","PSBRPC2",104,0) ; "RTN","PSBRPC2",105,0) ; IV/IVPB ward stock scan "RTN","PSBRPC2",106,0) ; "RTN","PSBRPC2",107,0) S PSBDIEN=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C") I PSBDIEN<1 Q "RTN","PSBRPC2",108,0) S PSBOIT=$$GET1^DIQ(50,PSBDIEN,"PHARMACY ORDERABLE ITEM","I") "RTN","PSBRPC2",109,0) I $D(^PSDRUG("A527",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A527",PSBDIEN,X)) Q:X="" D "RTN","PSBRPC2",110,0) .S PSBINACT=$$GET1^DIQ(52.7,X,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q "RTN","PSBRPC2",111,0) .S RESULTS(PSBCNT)="SOL"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1 "RTN","PSBRPC2",112,0) I $D(^PSDRUG("A526",PSBDIEN)) S X="" F S X=$O(^PSDRUG("A526",PSBDIEN,X)) Q:X="" D "RTN","PSBRPC2",113,0) .S PSBINACT=$$GET1^DIQ(52.6,X,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q "RTN","PSBRPC2",114,0) .S RESULTS(PSBCNT)="ADD"_U_X_U_$$GET1^DIQ(50,PSBDIEN_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1 "RTN","PSBRPC2",115,0) ; "RTN","PSBRPC2",116,0) I PSBTAB="PBTAB",$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C")'<1 S X=$$FIND1^DIC(50,"","AX",PSBDIEN,"B^C"),RESULTS(PSBCNT)="DD"_U_X_U_$$GET1^DIQ(50,X_",",.01),PSBCNT=PSBCNT+1,RESULTS(0)=PSBCNT-1 "RTN","PSBRPC2",117,0) Q "RTN","PSBRPC2",118,0) ; "RTN","PXRMTMED") 0^40^B9970277 "RTN","PXRMTMED",1,0) PXRMTMED ; SLC/PKR/PJH,MSC/JDA - Edit a reminder term. ;27APR2009 "RTN","PXRMTMED",2,0) ;;2.0;CLINICAL REMINDERS;**1,MSC**;Feb 04, 2005 "RTN","PXRMTMED",3,0) ; "RTN","PXRMTMED",4,0) ;======================================================= "RTN","PXRMTMED",5,0) N CS1,CS2,DA,DIC,DLAYGO,DTOUT,DUOUT,Y "RTN","PXRMTMED",6,0) GETNAME ;Get the name of the term to edit. "RTN","PXRMTMED",7,0) K DA,DIC,DLAYGO,DTOUT,DUOUT,Y "RTN","PXRMTMED",8,0) S DIC="^PXRMD(811.5," "RTN","PXRMTMED",9,0) S DIC(0)="AEMQL" "RTN","PXRMTMED",10,0) S DIC("A")="Select Reminder Term: " "RTN","PXRMTMED",11,0) S DLAYGO=811.5 "RTN","PXRMTMED",12,0) ;Set the starting place for additions. "RTN","PXRMTMED",13,0) D SETSTART^PXRMCOPY(DIC) "RTN","PXRMTMED",14,0) W ! "RTN","PXRMTMED",15,0) D ^DIC "RTN","PXRMTMED",16,0) I ($D(DTOUT))!($D(DUOUT)) Q "RTN","PXRMTMED",17,0) I Y=-1 G END "RTN","PXRMTMED",18,0) S DA=$P(Y,U,1) "RTN","PXRMTMED",19,0) S CS1=$$FILE^PXRMEXCS(811.5,DA) "RTN","PXRMTMED",20,0) D EDIT(DIC,DA) "RTN","PXRMTMED",21,0) I $G(DA)="" G GETNAME "RTN","PXRMTMED",22,0) S CS2=$$FILE^PXRMEXCS(811.5,DA) "RTN","PXRMTMED",23,0) I CS2=0 G GETNAME "RTN","PXRMTMED",24,0) I CS2'=CS1 D SEHIST^PXRMUTIL(811.5,DIC,DA) "RTN","PXRMTMED",25,0) G GETNAME "RTN","PXRMTMED",26,0) END ; "RTN","PXRMTMED",27,0) Q "RTN","PXRMTMED",28,0) ; "RTN","PXRMTMED",29,0) ;======================================================= "RTN","PXRMTMED",30,0) EDIT(ROOT,DA) ; "RTN","PXRMTMED",31,0) N CLASS,DIC,DIE,DR,DIDEL,PXRMTMD,RESULT,TCONT,Y "RTN","PXRMTMED",32,0) ;PXRMTMD is set by a xref on the .01 as a flag that the entire "RTN","PXRMTMED",33,0) ;entry is being deleted. "RTN","PXRMTMED",34,0) S CLASS=$P($G(^PXRMD(811.5,DA,100)),U,1) "RTN","PXRMTMED",35,0) S DIE=ROOT "RTN","PXRMTMED",36,0) I CLASS'="N"!(($G(PXRMINST)=1)&($G(DUZ(0))="@")) D "RTN","PXRMTMED",37,0) . S DR=".01" "RTN","PXRMTMED",38,0) . D ^DIE "RTN","PXRMTMED",39,0) . I $G(DA)'="" D CLASS(DA,DIE) "RTN","PXRMTMED",40,0) I $G(DA)="" Q "RTN","PXRMTMED",41,0) S TCONT=1 "RTN","PXRMTMED",42,0) F D FINDING(DIE,DA) Q:TCONT=0 "RTN","PXRMTMED",43,0) Q "RTN","PXRMTMED",44,0) ; "RTN","PXRMTMED",45,0) ;======================================================= "RTN","PXRMTMED",46,0) FINDING(DIE,DA,LIST) ; "RTN","PXRMTMED",47,0) N CFIEN,GLOB,IEN,LIST,NODE,WPIEN "RTN","PXRMTMED",48,0) N DEF,DEF1,DEF2,STATUS "RTN","PXRMTMED",49,0) S STATUS=0 "RTN","PXRMTMED",50,0) D DEF^PXRMRUTL("811.52",.DEF,.DEF1,.DEF2) "RTN","PXRMTMED",51,0) S NODE="^PXRMD(811.5)" "RTN","PXRMTMED",52,0) D LIST^PXRMREDT(NODE,DA,.LIST) "RTN","PXRMTMED",53,0) D DSPALL^PXRMREDF("T",NODE,DA,.LIST) "RTN","PXRMTMED",54,0) S DA(1)=DA "RTN","PXRMTMED",55,0) S IEN=DA "RTN","PXRMTMED",56,0) S DIC=DIE_DA(1)_",20," "RTN","PXRMTMED",57,0) S DIC(0)="QEAL" "RTN","PXRMTMED",58,0) S DIC("A")="Select Finding: " "RTN","PXRMTMED",59,0) D ^DIC I Y=-1 S DTOUT=1,TCONT=0 Q "RTN","PXRMTMED",60,0) S DIE=DIC "RTN","PXRMTMED",61,0) S DA=+Y,GLOB=$P($P(Y,U,2),";",2) Q:GLOB="" "RTN","PXRMTMED",62,0) I GLOB="PXRMD(811.4," S CFIEN=$P($P(Y,U,2),";",1) D "RTN","PXRMTMED",63,0) .I $D(^PXRMD(811.4,CFIEN,1))>0 D "RTN","PXRMTMED",64,0) ..W !!,"Computed Finding Description:" S WPIEN=0 "RTN","PXRMTMED",65,0) ..F S WPIEN=$O(^PXRMD(811.4,CFIEN,1,WPIEN)) Q:+WPIEN'>0 D "RTN","PXRMTMED",66,0) ...W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0)) "RTN","PXRMTMED",67,0) .E W !!,"No description defined for this computed finding" "RTN","PXRMTMED",68,0) .W ! "RTN","PXRMTMED",69,0) W !,"Editing Finding Number: "_$G(DA) "RTN","PXRMTMED",70,0) ;Finding record fields "RTN","PXRMTMED",71,0) S DR=".01;9;12;17" "RTN","PXRMTMED",72,0) S DR=DR_";14;15;18" "RTN","PXRMTMED",73,0) I GLOB="PXRMD(811.4," S DR=DR_";26" "RTN","PXRMTMED",74,0) ;Taxonomy - use inactive problems "RTN","PXRMTMED",75,0) I GLOB="PXD(811.2," S DR=DR_";10",STATUS=1 "RTN","PXRMTMED",76,0) ;Health Factor - within category rank "RTN","PXRMTMED",77,0) I GLOB="AUTTHF(" S DR=DR_";11" "RTN","PXRMTMED",78,0) ;Mental Health - scale "RTN","PXRMTMED",79,0) I GLOB="YTT(601," S DR=DR_";13" "RTN","PXRMTMED",80,0) I GLOB="RAMIS(71,"!(GLOB="ORD(101.43,") S DR=DR_";16",STATUS=1 "RTN","PXRMTMED",81,0) ;Rx Type "RTN","PXRMTMED",82,0) I GLOB="PSDRUG("!(GLOB="PS(50.605,")!(GLOB="PSNDF(50.6,") S DR=DR_";16",STATUS=1 "RTN","PXRMTMED",83,0) ;Condition "RTN","PXRMTMED",84,0) ; "RTN","PXRMTMED",85,0) ;Edit finding record "RTN","PXRMTMED",86,0) D ^DIE "RTN","PXRMTMED",87,0) I STATUS=1,$D(DA)>0 D STATUS^PXRMSTA1(.DA,"T") "RTN","PXRMTMED",88,0) S $P(^PXRMD(811.5,IEN,20,0),U,3)=0 "RTN","PXRMTMED",89,0) Q "RTN","PXRMTMED",90,0) ; "RTN","PXRMTMED",91,0) ;======================================================= "RTN","PXRMTMED",92,0) CLASS(DA,DIE) ; "RTN","PXRMTMED",93,0) F D Q:RESULT'=0 "RTN","PXRMTMED",94,0) . N DR,RESULT,X,Y "RTN","PXRMTMED",95,0) . W ! "RTN","PXRMTMED",96,0) . S DR="100" D ^DIE I $D(Y) Q "RTN","PXRMTMED",97,0) . ;Sponsor "RTN","PXRMTMED",98,0) . S DR="101" D ^DIE I $D(Y) Q "RTN","PXRMTMED",99,0) . ;Make sure Class and Sponsor Class are in synch. "RTN","PXRMTMED",100,0) . S RESULT=$$VSPONSOR^PXRMINTR(X) "RTN","PXRMTMED",101,0) . Q "RTN","PXRMTMED",102,0) ;Review date, Usage "RTN","PXRMTMED",103,0) S DR="102;1" D ^DIE I $D(Y) Q "RTN","PXRMTMED",104,0) Q "RTN","PXRMTMED",105,0) ; "RTN","RORHL7A") 0^32^B35660209 "RTN","RORHL7A",1,0) RORHL7A ;HCIOFO/SG MSC/JDS- HL7 UTILITIES ;30APR2009 "RTN","RORHL7A",2,0) ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006 "RTN","RORHL7A",3,0) ; "RTN","RORHL7A",4,0) Q "RTN","RORHL7A",5,0) ; "RTN","RORHL7A",6,0) ;***** ADDS THE SEGMENT TO THE HL7 MESSAGE BUFFER "RTN","RORHL7A",7,0) ; "RTN","RORHL7A",8,0) ; SEG Complete HL7 segment "RTN","RORHL7A",9,0) ; "RTN","RORHL7A",10,0) ; The ADDSEGC^RORHL7A procedure adds the HL7 segment to the HL7 "RTN","RORHL7A",11,0) ; message buffer defined by the ROREXT("HL7BUF") parameter "RTN","RORHL7A",12,0) ; (the ^TMP("HLS",$J), by default). The , and "RTN","RORHL7A",13,0) ; characters are replaced with spaces. Long segments are split "RTN","RORHL7A",14,0) ; among sub-nodes of the main segment node in the destination "RTN","RORHL7A",15,0) ; buffer. "RTN","RORHL7A",16,0) ; "RTN","RORHL7A",17,0) ; The RORHL array and some nodes of the ROREXT array must be "RTN","RORHL7A",18,0) ; initialized (either by the $$INIT^RORHL7 or manually) before "RTN","RORHL7A",19,0) ; calling this procedure. "RTN","RORHL7A",20,0) ; "RTN","RORHL7A",21,0) ADDSEGC(SEG) ; "RTN","RORHL7A",22,0) N I1,I2,MAXLEN,NODE,PTR,PTR1,SID,SL "RTN","RORHL7A",23,0) S NODE=ROREXT("HL7BUF"),PTR=$G(ROREXT("HL7PTR"))+1 "RTN","RORHL7A",24,0) S HLFS=RORHL("FS"),HLECH=RORHL("ECH") "RTN","RORHL7A",25,0) Q:$P(SEG,HLFS)="" ; Segment Name "RTN","RORHL7A",26,0) ;--- Assign the Set ID if necessary "RTN","RORHL7A",27,0) S SID=$$SETID($P(SEG,HLFS)) "RTN","RORHL7A",28,0) S:SID>0 $P(SEG,HLFS,2)=SID "RTN","RORHL7A",29,0) ;--- Remove empty trailing fields "RTN","RORHL7A",30,0) S I2=$L(SEG,HLFS) "RTN","RORHL7A",31,0) F I1=I2:-1:1 Q:$TR($P(SEG,HLFS,I1),HLECH)'="" "RTN","RORHL7A",32,0) S:I1MAXLEN "RTN","RORHL7A",39,0) . S I2=MAXLEN "RTN","RORHL7A",40,0) . F PTR1=1:1 S I1=I2+1,I2=I1+MAXLEN-1 Q:I1>SL D "RTN","RORHL7A",41,0) . . S @NODE@(PTR,PTR1)=$TR($E(SEG,I1,I2),$C(9,10,13)," ") "RTN","RORHL7A",42,0) ;--- Save the pointer "RTN","RORHL7A",43,0) S ROREXT("HL7PTR")=PTR "RTN","RORHL7A",44,0) Q "RTN","RORHL7A",45,0) ; "RTN","RORHL7A",46,0) ;***** ASSEMBLES THE SEGMENT AND ADDS IT TO THE HL7 MESSAGE BUFFER "RTN","RORHL7A",47,0) ; "RTN","RORHL7A",48,0) ; .FIELDS Reference to a local variable where the HL7 "RTN","RORHL7A",49,0) ; fields are stored "RTN","RORHL7A",50,0) ; "RTN","RORHL7A",51,0) ; FIELDS( "RTN","RORHL7A",52,0) ; 0) Segment name "RTN","RORHL7A",53,0) ; I, Field value "RTN","RORHL7A",54,0) ; i) Continuation of the value if it is "RTN","RORHL7A",55,0) ; ... longer than than 245 characters "RTN","RORHL7A",56,0) ; "RTN","RORHL7A",57,0) ; The ADDSEGF^RORHL7A procedure assembles the HL7 segment from "RTN","RORHL7A",58,0) ; provided field values and adds it to the HL7 message buffer "RTN","RORHL7A",59,0) ; defined by the ROREXT("HL7BUF") node (the ^TMP("HLS",$J), by "RTN","RORHL7A",60,0) ; default). The , and characters are replaced with "RTN","RORHL7A",61,0) ; spaces. Long segments are split among sub-nodes of the main "RTN","RORHL7A",62,0) ; segment node in the destination buffer. "RTN","RORHL7A",63,0) ; "RTN","RORHL7A",64,0) ; The RORHL array and some nodes of the ROREXT array must be "RTN","RORHL7A",65,0) ; initialized (either by the $$INIT^RORHL7 or manually) before "RTN","RORHL7A",66,0) ; calling this procedure. "RTN","RORHL7A",67,0) ; "RTN","RORHL7A",68,0) ADDSEGF(FIELDS) ; "RTN","RORHL7A",69,0) ; RORBUF Temporary buffer for the segment construction "RTN","RORHL7A",70,0) ; RORIS Current continuation subscript in the HL7 buffer "RTN","RORHL7A",71,0) ; RORNODE Closed root of the HL7 message buffer "RTN","RORHL7A",72,0) ; RORPTR Current subscript in the HL7 message buffer "RTN","RORHL7A",73,0) ; RORSL Number of characters that can be appended to the "RTN","RORHL7A",74,0) ; RORBUF before it has to be emptied into the HL7 "RTN","RORHL7A",75,0) ; message buffer "RTN","RORHL7A",76,0) ; "RTN","RORHL7A",77,0) N FLD,I,LASTFLD,RORBUF,RORIS,RORNODE,RORPTR,RORSL "RTN","RORHL7A",78,0) Q:$G(FIELDS(0))="" ; Segment Name "RTN","RORHL7A",79,0) S RORNODE=ROREXT("HL7BUF"),RORPTR=$G(ROREXT("HL7PTR"))+1 "RTN","RORHL7A",80,0) S HLFS=RORHL("FS"),HLECH=RORHL("ECH") "RTN","RORHL7A",81,0) ;--- Assign the Set ID if necessary "RTN","RORHL7A",82,0) S I=$$SETID(FIELDS(0)) "RTN","RORHL7A",83,0) S:I>0 FIELDS(1)=I "RTN","RORHL7A",84,0) ;--- Remove empty trailing fields "RTN","RORHL7A",85,0) S I=$NA(FIELDS) "RTN","RORHL7A",86,0) N A,CNT F S I=$Q(@I) Q:I="" S CNT=$G(CNT)+1,A(CNT)=I I $TR(@I,HLECH)'="" K A,CNT "RTN","RORHL7A",87,0) F I=1:1 Q:'$D(A(I)) K @A(I) "RTN","RORHL7A",88,0) ;--- Initialize construction variables "RTN","RORHL7A",89,0) S RORBUF=FIELDS(0),I=$L(RORBUF) "RTN","RORHL7A",90,0) S ROREXT("HL7SIZE")=$G(ROREXT("HL7SIZE"))+I+1 "RTN","RORHL7A",91,0) S RORIS=0,RORSL=245-I "RTN","RORHL7A",92,0) ;--- Append the fields and store the segment "RTN","RORHL7A",93,0) S LASTFLD=+$O(FIELDS(" "),-1) "RTN","RORHL7A",94,0) F FLD=1:1:LASTFLD D "RTN","RORHL7A",95,0) . D APPEND(HLFS_$G(FIELDS(FLD))) "RTN","RORHL7A",96,0) . ;--- Process the field continuation nodes "RTN","RORHL7A",97,0) . S I="" "RTN","RORHL7A",98,0) . F S I=$O(FIELDS(FLD,I)) Q:I="" D APPEND(FIELDS(FLD,I)) "RTN","RORHL7A",99,0) ;--- Flush the buffer if necessary "RTN","RORHL7A",100,0) D:RORBUF'="" "RTN","RORHL7A",101,0) . I 'RORIS S @RORNODE@(RORPTR)=RORBUF Q "RTN","RORHL7A",102,0) . S @RORNODE@(RORPTR,RORIS)=RORBUF "RTN","RORHL7A",103,0) S ROREXT("HL7PTR")=RORPTR "RTN","RORHL7A",104,0) Q "RTN","RORHL7A",105,0) ; "RTN","RORHL7A",106,0) ;***** APPENDS THE FIELD VALUE TO THE HL7 SEGMENT "RTN","RORHL7A",107,0) ; "RTN","RORHL7A",108,0) ; VAL Value of the field (or its part) "RTN","RORHL7A",109,0) ; "RTN","RORHL7A",110,0) ; This is an internal function. Do not call it directly. "RTN","RORHL7A",111,0) ; "RTN","RORHL7A",112,0) APPEND(VAL) ; "RTN","RORHL7A",113,0) N BASE,L "RTN","RORHL7A",114,0) S VAL=$TR(VAL,$C(9,10,13)," "),L=$L(VAL) "RTN","RORHL7A",115,0) S ROREXT("HL7SIZE")=$G(ROREXT("HL7SIZE"))+L "RTN","RORHL7A",116,0) I L'>RORSL S RORBUF=RORBUF_VAL,RORSL=RORSL-L Q "RTN","RORHL7A",117,0) ;--- "RTN","RORHL7A",118,0) S RORBUF=RORBUF_$E(VAL,1,RORSL),L=L-RORSL "RTN","RORHL7A",119,0) S BASE=1 "RTN","RORHL7A",120,0) F D Q:L'>0 "RTN","RORHL7A",121,0) . I 'RORIS S @RORNODE@(RORPTR)=RORBUF "RTN","RORHL7A",122,0) . E S @RORNODE@(RORPTR,RORIS)=RORBUF "RTN","RORHL7A",123,0) . S BASE=BASE+RORSL,RORIS=RORIS+1,RORSL=245 "RTN","RORHL7A",124,0) . S RORBUF=$E(VAL,BASE,BASE+RORSL-1),L=L-RORSL "RTN","RORHL7A",125,0) S RORSL=-L "RTN","RORHL7A",126,0) Q "RTN","RORHL7A",127,0) ; "RTN","RORHL7A",128,0) ;***** RETURNS THE BHS SEGMENT "RTN","RORHL7A",129,0) ; "RTN","RORHL7A",130,0) ; BID Batch message ID "RTN","RORHL7A",131,0) ; "RTN","RORHL7A",132,0) ; [BDT] Batch message creation time in internal FileMan "RTN","RORHL7A",133,0) ; format (NOW by default) "RTN","RORHL7A",134,0) ; "RTN","RORHL7A",135,0) ; [COMMENT] Optional comment "RTN","RORHL7A",136,0) ; "RTN","RORHL7A",137,0) ; The RORHL local variable must be initialized by the $$INIT^RORHL7 "RTN","RORHL7A",138,0) ; function before calling this entry point. "RTN","RORHL7A",139,0) ; "RTN","RORHL7A",140,0) BHS(BID,BDT,COMMENT) ; "RTN","RORHL7A",141,0) N CS,SEG,TMP "RTN","RORHL7A",142,0) D BHS^HLFNC3(.RORHL,BID,.SEG) "RTN","RORHL7A",143,0) Q:$G(SEG)="" "" "RTN","RORHL7A",144,0) S HLFS=RORHL("FS"),HLECH=RORHL("ECH"),CS=$E(HLECH,1) "RTN","RORHL7A",145,0) ;--- Post-processing "RTN","RORHL7A",146,0) S SEG=SEG_$G(SEG(1)) "RTN","RORHL7A",147,0) S:$G(BDT)'>0 BDT=$$NOW^XLFDT "RTN","RORHL7A",148,0) S TMP=$E($P($$SITE^VASITE,U,3),1,3) "RTN","RORHL7A",149,0) S $P(SEG,HLFS,4)=TMP_CS_$G(^XMB("NETNAME"))_CS_"DNS" "RTN","RORHL7A",150,0) S $P(SEG,HLFS,5)="ROR AAC" "RTN","RORHL7A",151,0) S $P(SEG,HLFS,7)=$$FMTHL7^XLFDT(BDT) "RTN","RORHL7A",152,0) S TMP=$P(SEG,HLFS,9) "RTN","RORHL7A",153,0) S $P(TMP,CS,3)=$P(TMP,CS,3)_$E(HLECH,2)_$G(RORHL("ETN")) "RTN","RORHL7A",154,0) S $P(SEG,HLFS,9)=TMP "RTN","RORHL7A",155,0) S $P(SEG,HLFS,10)=$G(COMMENT) "RTN","RORHL7A",156,0) Q SEG "RTN","RORHL7A",157,0) ; "RTN","RORHL7A",158,0) ;***** RETURNS BTS SEGMENT "RTN","RORHL7A",159,0) ; "RTN","RORHL7A",160,0) ; MSGCNT Batch message count "RTN","RORHL7A",161,0) ; [COMMENT] Batch comment "RTN","RORHL7A",162,0) ; "RTN","RORHL7A",163,0) ; The RORHL variable must be initialized by the INIT^HLFNC2 before "RTN","RORHL7A",164,0) ; calling this entry point "RTN","RORHL7A",165,0) ; "RTN","RORHL7A",166,0) BTS(MSGCNT,COMMENT) ; "RTN","RORHL7A",167,0) Q "BTS"_RORHL("FS")_MSGCNT_RORHL("FS")_$G(COMMENT) "RTN","RORHL7A",168,0) ; "RTN","RORHL7A",169,0) ;***** LOADS THE HL7 FIELD (OR ITS PART) TO THE BUFFER "RTN","RORHL7A",170,0) ; "RTN","RORHL7A",171,0) ; VAL Value of the field (or its part) "RTN","RORHL7A",172,0) ; "RTN","RORHL7A",173,0) ; FLD Number of the field in the segment (piece number) "RTN","RORHL7A",174,0) ; "RTN","RORHL7A",175,0) FIELD(VAL,FLD) ; "RTN","RORHL7A",176,0) N BASE,L "RTN","RORHL7A",177,0) S:FLD>RORFLD RORFLD=FLD,RORIS=0,RORSL=245 "RTN","RORHL7A",178,0) S L=$L(VAL),BASE=1 "RTN","RORHL7A",179,0) F RORIS=RORIS:1 D Q:L'>0 "RTN","RORHL7A",180,0) . I 'RORIS S RORSEG(RORFLD)=$G(RORSEG(RORFLD))_$E(VAL,BASE,BASE+RORSL-1) "RTN","RORHL7A",181,0) . E S RORSEG(RORFLD,RORIS)=$G(RORSEG(RORFLD,RORIS))_$E(VAL,BASE,BASE+RORSL-1) "RTN","RORHL7A",182,0) . S BASE=BASE+RORSL,L=L-RORSL,RORSL=245 "RTN","RORHL7A",183,0) S RORSL=-L "RTN","RORHL7A",184,0) Q "RTN","RORHL7A",185,0) ; "RTN","RORHL7A",186,0) ;***** LOADS THE HL7 SEGMENT INTO THE RPOVIDED BUFFER "RTN","RORHL7A",187,0) ; "RTN","RORHL7A",188,0) ; .RORSEG Reference to a local variable where the HL7 "RTN","RORHL7A",189,0) ; fields will be stored. The fields are stored "RTN","RORHL7A",190,0) ; in the following format: "RTN","RORHL7A",191,0) ; "RTN","RORHL7A",192,0) ; RORSEG(FldNum)=FldVal "RTN","RORHL7A",193,0) ; "RTN","RORHL7A",194,0) ; If the value is longer that 245 characters then "RTN","RORHL7A",195,0) ; the continuation nodes are created: "RTN","RORHL7A",196,0) ; "RTN","RORHL7A",197,0) ; RORSEG(FldNum,#)=FldValCont "RTN","RORHL7A",198,0) ; "RTN","RORHL7A",199,0) ; ROR8SRC Closed root of the source buffer containing "RTN","RORHL7A",200,0) ; the HL7 segment "RTN","RORHL7A",201,0) ; "RTN","RORHL7A",202,0) LOADSEG(RORSEG,ROR8SRC) ; "RTN","RORHL7A",203,0) N BUF,FLD,I,IFL,NFL,RORFLD,RORIS,RORSL "RTN","RORHL7A",204,0) S HLFS=RORHL("FS") K RORSEG "RTN","RORHL7A",205,0) ;--- Process the main segment "RTN","RORHL7A",206,0) S BUF=$G(@ROR8SRC),NFL=$L(BUF,HLFS) "RTN","RORHL7A",207,0) F IFL=1:1:NFL S RORSEG(IFL-1)=$P(BUF,HLFS,IFL) "RTN","RORHL7A",208,0) Q:$D(@ROR8SRC)<10 "RTN","RORHL7A",209,0) ;--- Process the sub-segments "RTN","RORHL7A",210,0) S (FLD,RORFLD)=NFL-1,RORIS=0,RORSL=245-$L(RORSEG(FLD)) "RTN","RORHL7A",211,0) S I="" "RTN","RORHL7A",212,0) F S I=$O(@ROR8SRC@(I)) Q:I="" D "RTN","RORHL7A",213,0) . S BUF=@ROR8SRC@(I),NFL=$L(BUF,HLFS) "RTN","RORHL7A",214,0) . D FIELD($P(BUF,HLFS),FLD) "RTN","RORHL7A",215,0) . F IFL=2:1:NFL S FLD=FLD+1 D FIELD($P(BUF,HLFS,IFL),FLD) "RTN","RORHL7A",216,0) Q "RTN","RORHL7A",217,0) ; "RTN","RORHL7A",218,0) ;***** RETURNS TEXT EXPLANATIONS OF THE HL7 MESSAGE STATUS "RTN","RORHL7A",219,0) ; "RTN","RORHL7A",220,0) ; MSGST Status value returned by the $$MSGSTAT^HLUTIL "RTN","RORHL7A",221,0) ; "RTN","RORHL7A",222,0) MSGSTXT(MSGST) ; "RTN","RORHL7A",223,0) N ST S ST=+MSGST "RTN","RORHL7A",224,0) Q:'ST "Message does not exist" "RTN","RORHL7A",225,0) Q:ST=1 "Waiting in queue" "RTN","RORHL7A",226,0) Q:ST=1.5 "Opening connection" "RTN","RORHL7A",227,0) Q:ST=1.7 "Awaiting response" "RTN","RORHL7A",228,0) Q:ST=2 "Awaiting application ack" "RTN","RORHL7A",229,0) Q:ST=3 "Successfully completed" "RTN","RORHL7A",230,0) Q:ST=4 "Error" "RTN","RORHL7A",231,0) Q:ST=8 "Being generated" "RTN","RORHL7A",232,0) Q:ST=9 "Awaiting processing" "RTN","RORHL7A",233,0) Q "Unknown" "RTN","RORHL7A",234,0) ; "RTN","RORHL7A",235,0) ;***** ASSIGNS THE 'SET ID' "RTN","RORHL7A",236,0) ; "RTN","RORHL7A",237,0) ; SEGNAME Name of the HL7 segment "RTN","RORHL7A",238,0) ; [DISINC] Disable increment of the Set ID "RTN","RORHL7A",239,0) ; "RTN","RORHL7A",240,0) ; Return Values: "RTN","RORHL7A",241,0) ; "" Not required for this segment "RTN","RORHL7A",242,0) ; >0 Value for the Set ID field "RTN","RORHL7A",243,0) ; "RTN","RORHL7A",244,0) SETID(SEGNAME,DISINC) ; "RTN","RORHL7A",245,0) N SETID "RTN","RORHL7A",246,0) Q:$G(SEGNAME)="" "" "RTN","RORHL7A",247,0) S SETID=+$G(ROREXT("HL7SID",SEGNAME)) "RTN","RORHL7A",248,0) Q:SETID'>0 "" "RTN","RORHL7A",249,0) S:'$G(DISINC) ROREXT("HL7SID",SEGNAME)=SETID+1 "RTN","RORHL7A",250,0) Q SETID "RTN","VALMW3") 0^41^B21033865 "RTN","VALMW3",1,0) VALMW3 ; ALB/MJK,MSC/JDA - Create transport routines for LM;27APR2009 "RTN","VALMW3",2,0) ;;1;List Manager;**MSC**;Aug 13, 1993 "RTN","VALMW3",3,0) ; "RTN","VALMW3",4,0) EN ; -- exporter main entry point "RTN","VALMW3",5,0) N VALMSYS,VALMNS,VALMROU,VALMAX "RTN","VALMW3",6,0) S U="^",DTIME=600 K ^UTILITY($J) "RTN","VALMW3",7,0) D HOME^%ZIS "RTN","VALMW3",8,0) W @IOF,!?20,"*** List Template Export Utility ***" "RTN","VALMW3",9,0) I '$$DUZ() G ENQ "RTN","VALMW3",10,0) S VALMSYS=$$OS() I VALMSYS="" G ENQ "RTN","VALMW3",11,0) S VALMNS=$$NS() I VALMNS="" G ENQ "RTN","VALMW3",12,0) S VALMROU=$$ROU(.VALMNS) I VALMROU="" G ENQ "RTN","VALMW3",13,0) S VALMAX=$$MAX() I 'VALMAX G ENQ "RTN","VALMW3",14,0) W !!!,">>> Exporting LIST TEMPLATES with namespace '"_VALMNS_"'." "RTN","VALMW3",15,0) D BLD,FILE(.VALMROU) "RTN","VALMW3",16,0) ENQ Q "RTN","VALMW3",17,0) ; "RTN","VALMW3",18,0) ; "RTN","VALMW3",19,0) DUZ() ; -- check duz and duz(0) "RTN","VALMW3",20,0) I $S('$D(DUZ(0)):1,DUZ(0)'="@":1,1:0) D "RTN","VALMW3",21,0) .W !,"PROGRAMMER ACCESS REQUIRED",! "RTN","VALMW3",22,0) .S Y=0 "RTN","VALMW3",23,0) E S Y=1 "RTN","VALMW3",24,0) Q Y "RTN","VALMW3",25,0) ; "RTN","VALMW3",26,0) OS() ; -- get os # "RTN","VALMW3",27,0) I $D(^%ZOSF("OS"))#2 D "RTN","VALMW3",28,0) .S Y=+$P(^("OS"),"^",2) "RTN","VALMW3",29,0) E S Y=0 "RTN","VALMW3",30,0) Q Y "RTN","VALMW3",31,0) ; "RTN","VALMW3",32,0) NS() ; -- ask for namespace "RTN","VALMW3",33,0) NS1 S VALMNS="" "RTN","VALMW3",34,0) W !!,">>> Enter the Name of the Package (2-4 characters): " "RTN","VALMW3",35,0) R X:$S($D(DTIME):DTIME,1:60) G NSQ:"^"[X "RTN","VALMW3",36,0) I X'?1U1.NU!($L(X)>4) D NS^VALMW5 G NS1 "RTN","VALMW3",37,0) S VALMNS="",DIC="^DIC(9.4,",DIC(0)="EZ",D="C" D IX^DIC "RTN","VALMW3",38,0) I Y>0 S SDPK=+Y,VALMNS=$P(Y(0),U,2) "RTN","VALMW3",39,0) S:Y<1!(VALMNS="") VALMNS=$$ADHOC(X) "RTN","VALMW3",40,0) NSQ Q VALMNS "RTN","VALMW3",41,0) ; "RTN","VALMW3",42,0) ROU(VALMNS) ; -- ask for export routine name "RTN","VALMW3",43,0) N ROU,DIR,X,Q "RTN","VALMW3",44,0) ROU1 S VALMROU="" "RTN","VALMW3",45,0) W ! S:$G(VALMNS)]"" DIR("B")=VALMNS_"L" "RTN","VALMW3",46,0) S DIR("A")=">>> Enter Routine Name",DIR(0)="F^2:6^" D ^DIR K DIR "RTN","VALMW3",47,0) G ROUQ:"^"[Y S VALMROU=Y "RTN","VALMW3",48,0) W !!,"I am going to create a series of '",VALMROU,"*' routines." "RTN","VALMW3",49,0) I $D(^%ZOSF("TEST"))#2 X ^("TEST") I W *7,!,"but '"_VALMROU_"' is ALREADY ON FILE!" S Q=1 "RTN","VALMW3",50,0) W !,"Is that OK" D YN^DICN "RTN","VALMW3",51,0) I %<0!(%=2) S:%=2 VALMROU="" G ROUQ "RTN","VALMW3",52,0) I '% D ROU^VALMW5 G ROU1 "RTN","VALMW3",53,0) ROUQ Q VALMROU "RTN","VALMW3",54,0) ; "RTN","VALMW3",55,0) MAX() ; -- ask for max size of routines "RTN","VALMW3",56,0) N Y "RTN","VALMW3",57,0) MAX1 S Y="" "RTN","VALMW3",58,0) W !!,">>> MAXIMUM ROUTINE SIZE(BYTES): ",^DD("ROU"),"// " "RTN","VALMW3",59,0) R Y:$S($D(DTIME):DTIME,1:60) I '$T G MAXQ "RTN","VALMW3",60,0) S:Y="" Y=^DD("ROU") "RTN","VALMW3",61,0) I Y[U S Y="" G MAXQ "RTN","VALMW3",62,0) I Y\1'=Y!(Y<2000)!(Y>9999) D MAX^VALMW5 G MAX1 "RTN","VALMW3",63,0) MAXQ Q Y "RTN","VALMW3",64,0) ; "RTN","VALMW3",65,0) ADHOC(X) ; -- pick any namespace "RTN","VALMW3",66,0) L W !!,"Package "_X_" not found" "RTN","VALMW3",67,0) W !,"Please enter the package namespace you wish to export: " "RTN","VALMW3",68,0) R X:300 "RTN","VALMW3",69,0) I '$T!(X="")!(X'?1A.E) S X="" G LQ "RTN","VALMW3",70,0) I $L(X)>4 W !,"Namespace too long" G L "RTN","VALMW3",71,0) LQ Q X "RTN","VALMW3",72,0) ; "RTN","VALMW3",73,0) BLD ; -- build utility "RTN","VALMW3",74,0) N VALMLN,VALMX,VALMNAME,VALM,VALMGLB "RTN","VALMW3",75,0) S VALMLN=0,VALMX=VALMNS "RTN","VALMW3",76,0) F S VALMX=$O(^SD(409.61,"B",VALMX)) Q:VALMX=""!($E(VALMX,1,$L(VALMNS))'=VALMNS) S VALM=+$O(^(VALMX,0)) I $D(^SD(409.61,VALM,0)),$P(^(0),U,7) S VALMNAME=$P(^(0),U) D "RTN","VALMW3",77,0) .W !?5,"o ",VALMNAME "RTN","VALMW3",78,0) .D SET(" W !,""'"_VALMNAME_"' List Template...""") "RTN","VALMW3",79,0) .D SET(" S DA=$O(^SD(409.61,""B"","""_VALMNAME_""",0)),DIK=""^SD(409.61,"" D ^DIK:DA") "RTN","VALMW3",80,0) .D SET(" K DO,DD S DIC(0)=""L"",DIC=""^SD(409.61,"",X="""_VALMNAME_""" D FILE^DICN S VALM=+Y") "RTN","VALMW3",81,0) .D SET(" I VALM>0 D") "RTN","VALMW3",82,0) .; "RTN","VALMW3",83,0) .S VALMGLB="^SD(409.61,"_VALM_",",X=VALMGLB_"-1)" "RTN","VALMW3",84,0) .F S X=$Q(@X) Q:$E(X,1,$L(VALMGLB))'=VALMGLB D:X'[",""B""," SET(" .S ^SD(409.61,VALM,"_$P(X,VALMGLB,2,99)_"="""_$$QUOTE(@X)_"""") "RTN","VALMW3",85,0) .; "RTN","VALMW3",86,0) .D SET(" .S DA=VALM,DIK=""^SD(409.61,"" D IX1^DIK K DA,DIK") "RTN","VALMW3",87,0) .D SET(" .W ""Filed.""") "RTN","VALMW3",88,0) .D SET(" ;") "RTN","VALMW3",89,0) D SET(" K DIC,DIK,VALM,X,DA Q") "RTN","VALMW3",90,0) Q3 Q "RTN","VALMW3",91,0) ; "RTN","VALMW3",92,0) SET(X) ; -- set line utility "RTN","VALMW3",93,0) S VALMLN=VALMLN+1,^UTILITY($J,VALMLN,0)=X W "." "RTN","VALMW3",94,0) Q "RTN","VALMW3",95,0) ; "RTN","VALMW3",96,0) QUOTE(X) ; -- add double quotes "RTN","VALMW3",97,0) N P,L "RTN","VALMW3",98,0) S P=1,L=$L(X) "RTN","VALMW3",99,0) F S P=$F(X,"""",P) Q:'P!(P>(L+1)) S X=$E(X,1,P-1)_""""_$E(X,P,L),L=L+1,P=P+1 "RTN","VALMW3",100,0) Q X "RTN","VALMW3",101,0) ; "RTN","VALMW3",102,0) FILE(VALMROU) ; -- file routines "RTN","VALMW3",103,0) N %H,VALMDATE,VALMNUM,VALMLN "RTN","VALMW3",104,0) S %H=+$H D YX^%DTC "RTN","VALMW3",105,0) S VALMDATE=$E(Y,5,6)_"-"_$E(Y,1,3)_"-"_$E(Y,9,12) "RTN","VALMW3",106,0) S VALMNUM="",VALMLN=0 "RTN","VALMW3",107,0) F D SAVE(.VALMROU,.VALMNUM,.VALMLN,.VALMDATE) Q:VALMLN="" S VALMNUM=VALMNUM+1 "RTN","VALMW3",108,0) Q "RTN","VALMW3",109,0) ; "RTN","VALMW3",110,0) SAVE(VALMROU,VALMNUM,VALMLN,VALMDATE) ; -- save to routine "RTN","VALMW3",111,0) N LINE,SIZE "RTN","VALMW3",112,0) K ^UTILITY($J,0) S ^(0,1)=VALMROU_VALMNUM_" ; List Template Exporter ; "_VALMDATE,^(1.1)=" ;; ;",SIZE=0 "RTN","VALMW3",113,0) F LINE=2:1 S VALMLN=$O(^UTILITY($J,VALMLN)) Q:VALMLN="" S ^UTILITY($J,0,LINE)=^(VALMLN,0),SIZE=$L(^(LINE))+SIZE I $E(^(LINE),1,2)'=" .",SIZE+700>VALMAX Q "RTN","VALMW3",114,0) I VALMLN,$O(^UTILITY($J,VALMLN)) S ^UTILITY($J,0,LINE+1)=" G ^"_VALMROU_(VALMNUM+1) "RTN","VALMW3",115,0) S X=VALMROU_VALMNUM X ^DD("OS",VALMSYS,"ZS") W !,X_" has been filed..." "RTN","VALMW3",116,0) Q "RTN","VALMW3",117,0) ; "RTN","XOBVLL") 0^19^B18012967 "RTN","XOBVLL",1,0) XOBVLL ;; mjk/alb MSC/JDA - VistALink Listen and Spawn Code ;13APR2009 "RTN","XOBVLL",2,0) ;;1.5;VistALink;**MSC**;Sep 09, 2005 "RTN","XOBVLL",3,0) ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026] "RTN","XOBVLL",4,0) ; "RTN","XOBVLL",5,0) QUIT "RTN","XOBVLL",6,0) ; "RTN","XOBVLL",7,0) ; ***deprecated*** tag ; Use START^XOBVTCP instead "RTN","XOBVLL",8,0) START(SOCKET) ; -- start listener "RTN","XOBVLL",9,0) DO START^XOBVTCP(SOCKET) "RTN","XOBVLL",10,0) QUIT "RTN","XOBVLL",11,0) ; "RTN","XOBVLL",12,0) ; ***deprecated*** tag ; Use UCX^XOBVTCP instead "RTN","XOBVLL",13,0) UCX ; -- VMS TCPIP (UCX) multi-thread entry point "RTN","XOBVLL",14,0) ; -- Called from VistALink .com files "RTN","XOBVLL",15,0) GOTO UCX^XOBVTCP "RTN","XOBVLL",16,0) ; "RTN","XOBVLL",17,0) SPAWN ; -- spawned process "RTN","XOBVLL",18,0) NEW X,XOBSTOP,XOBPORT,XOBHDLR,XOBLASTR "RTN","XOBVLL",19,0) ; "RTN","XOBVLL",20,0) SET XOBSTOP=0 "RTN","XOBVLL",21,0) SET XOBPORT=IO "RTN","XOBVLL",22,0) SET U="^" "RTN","XOBVLL",23,0) ; "RTN","XOBVLL",24,0) ; -- initialize timestamp for last time request made (used for debugging) "RTN","XOBVLL",25,0) SET XOBLASTR=0 "RTN","XOBVLL",26,0) ; "RTN","XOBVLL",27,0) ; -- set error trap "RTN","XOBVLL",28,0) ;Set up the error trap "RTN","XOBVLL",29,0) SET $ETRAP="DO ^%ZTER HALT" "RTN","XOBVLL",30,0) ; "RTN","XOBVLL",31,0) ; -- attempt to share the license; must have TCP port open first "RTN","XOBVLL",32,0) USE XOBPORT IF $TEXT(SHARELIC^%ZOSV)'="" DO SHARELIC^%ZOSV(1) "RTN","XOBVLL",33,0) ; "RTN","XOBVLL",34,0) ; -- start RUM for VistALink Handler "RTN","XOBVLL",35,0) DO LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,1) "RTN","XOBVLL",36,0) ; "RTN","XOBVLL",37,0) SET:^%ZOSF("OS")["GT.M" X=$$GTM^XOBVRH(.XOBHDLR) "RTN","XOBVLL",38,0) ; -- cache/initialize startup request handlers "RTN","XOBVLL",39,0) SET:^%ZOSF("OS")["OpenM" X=$$CACHE^XOBVRH(.XOBHDLR) "RTN","XOBVLL",40,0) IF 'X DO RMERR^XOBVRM(184001,$PIECE(X,U,2)) QUIT "RTN","XOBVLL",41,0) ; "RTN","XOBVLL",42,0) ; -- initialize tcp processing variables "RTN","XOBVLL",43,0) DO INIT^XOBVSKT "RTN","XOBVLL",44,0) ; "RTN","XOBVLL",45,0) ; -- change job name if possible "RTN","XOBVLL",46,0) DO SETNM^%ZOSV("VLink_"_$$CNV^XLFUTL($J,16)) "RTN","XOBVLL",47,0) ; "RTN","XOBVLL",48,0) ; -- loop until told to stop "RTN","XOBVLL",49,0) FOR DO NXTCALL QUIT:XOBSTOP "RTN","XOBVLL",50,0) ; "RTN","XOBVLL",51,0) ; -- final/clean tcp processing variables "RTN","XOBVLL",52,0) DO FINAL^XOBVSKT "RTN","XOBVLL",53,0) ; "RTN","XOBVLL",54,0) ; -- stop RUM for VistALink Handler "RTN","XOBVLL",55,0) DO LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,2) "RTN","XOBVLL",56,0) ; "RTN","XOBVLL",57,0) QUIT "RTN","XOBVLL",58,0) ; "RTN","XOBVLL",59,0) NXTCALL ; -- do next call "RTN","XOBVLL",60,0) NEW X,XOBROOT,XOBREAD,XOBTO,XOBFIRST,XOBOK,XOBRL,XOBDATA "RTN","XOBVLL",61,0) ; "RTN","XOBVLL",62,0) ; -- set up error trap "RTN","XOBVLL",63,0) NEW $ESTACK SET $ETRAP="DO SYSERR^XOBVLL" "RTN","XOBVLL",64,0) ; "RTN","XOBVLL",65,0) ; -- setup environment variables "RTN","XOBVLL",66,0) NEW DIQUIET SET DIQUIET=1 "RTN","XOBVLL",67,0) SET U="^",DTIME=$GET(DTIME,900),DT=$$DT^XLFDT() "RTN","XOBVLL",68,0) ; "RTN","XOBVLL",69,0) ; -- initialize 'current' request handler to empty string "RTN","XOBVLL",70,0) SET XOBHDLR="" "RTN","XOBVLL",71,0) ; "RTN","XOBVLL",72,0) ; -- # of chars to get on first read / read 11 for Broker initial read "RTN","XOBVLL",73,0) SET XOBREAD=11 "RTN","XOBVLL",74,0) ; "RTN","XOBVLL",75,0) ; -- get J2SE heartbet rate for timeout plus network latency factor "RTN","XOBVLL",76,0) SET XOBTO=$$GETRATE^XOBVLIB()+$$GETDELTA^XOBVLIB() "RTN","XOBVLL",77,0) ; "RTN","XOBVLL",78,0) ; -- get J2EE timeout value for app serv environment "RTN","XOBVLL",79,0) IF $GET(XOBSYS("ENV"))="j2ee" SET XOBTO=$$GETASTO^XOBVLIB() "RTN","XOBVLL",80,0) ; "RTN","XOBVLL",81,0) ; -- set first read flag "RTN","XOBVLL",82,0) SET XOBFIRST=1 "RTN","XOBVLL",83,0) ; "RTN","XOBVLL",84,0) ; -- setup intake global "RTN","XOBVLL",85,0) SET XOBROOT=$NAME(^TMP("XOBVLL",$JOB)) "RTN","XOBVLL",86,0) KILL @XOBROOT "RTN","XOBVLL",87,0) ; "RTN","XOBVLL",88,0) ; -- read from socket port "RTN","XOBVLL",89,0) USE XOBPORT "RTN","XOBVLL",90,0) SET XOBOK=$$READ^XOBVSKT(XOBROOT,.XOBREAD,.XOBTO,.XOBFIRST,.XOBSTOP,.XOBDATA,.XOBHDLR) "RTN","XOBVLL",91,0) ; "RTN","XOBVLL",92,0) ; -- timed out ; cleanup user and exit "RTN","XOBVLL",93,0) IF 'XOBOK!(XOBSTOP) DO GOTO NXTCALLQ "RTN","XOBVLL",94,0) . IF $GET(DUZ) DO CLEAN^XOBSCAV1 "RTN","XOBVLL",95,0) . SET XOBSTOP=1 "RTN","XOBVLL",96,0) ; "RTN","XOBVLL",97,0) ; -- need null device "RTN","XOBVLL",98,0) IF '$DATA(XOBNULL) DO ERROR(181002,$$EZBLD^DIALOG(181002),XOBPORT) SET XOBSTOP=1 GOTO NXTCALLQ "RTN","XOBVLL",99,0) ; "RTN","XOBVLL",100,0) ; -- call request manager "RTN","XOBVLL",101,0) SET XOBOK=$$EN^XOBVRM(XOBROOT,.XOBDATA,.XOBHDLR) "RTN","XOBVLL",102,0) ; -- timestamp last time request made "RTN","XOBVLL",103,0) SET XOBLASTR=$$NOW^XLFDT() "RTN","XOBVLL",104,0) ; -- cleanup intake global "RTN","XOBVLL",105,0) KILL @XOBROOT "RTN","XOBVLL",106,0) ; "RTN","XOBVLL",107,0) NXTCALLQ ; -- exit "RTN","XOBVLL",108,0) QUIT "RTN","XOBVLL",109,0) ; "RTN","XOBVLL",110,0) ; ---------------------------------------------------------------------------------- "RTN","XOBVLL",111,0) ; System Error Handler "RTN","XOBVLL",112,0) ; ---------------------------------------------------------------------------------- "RTN","XOBVLL",113,0) SYSERR ; -- send system error message "RTN","XOBVLL",114,0) ; -- If we get an error in the error handler just Halt "RTN","XOBVLL",115,0) SET $ETRAP="D ^%ZTER HALT" "RTN","XOBVLL",116,0) ; "RTN","XOBVLL",117,0) DO ERROR(181001,$$EZBLD^DIALOG(181001,$$EC^%ZOSV),XOBPORT) ; -- Get the error code "RTN","XOBVLL",118,0) QUIT "RTN","XOBVLL",119,0) ; "RTN","XOBVLL",120,0) ERROR(XOBEC,XOBMSG,XOBPORT) ; -- send error message "RTN","XOBVLL",121,0) NEW XOBDAT "RTN","XOBVLL",122,0) ; "RTN","XOBVLL",123,0) ; -- If we get an error in the error handler just Halt "RTN","XOBVLL",124,0) SET $ETRAP="D ^%ZTER HALT" "RTN","XOBVLL",125,0) ; "RTN","XOBVLL",126,0) ; -- set up error info "RTN","XOBVLL",127,0) SET XOBDAT("MESSAGE TYPE")=3 "RTN","XOBVLL",128,0) SET XOBDAT("ERRORS",1,"CODE")=XOBEC "RTN","XOBVLL",129,0) SET XOBDAT("ERRORS",1,"ERROR TYPE")="system" "RTN","XOBVLL",130,0) SET XOBDAT("ERRORS",1,"FAULT STRING")="System Error" "RTN","XOBVLL",131,0) SET XOBDAT("ERRORS",1,"CDATA")=1 "RTN","XOBVLL",132,0) SET XOBDAT("ERRORS",1,"MESSAGE",1)=XOBMSG "RTN","XOBVLL",133,0) ; "RTN","XOBVLL",134,0) ; -- if serious error, save error info, logout, and halt "RTN","XOBVLL",135,0) IF XOBMSG[""!(XOBMSG["")!(XOBMSG["")!(XOBMSG["READERR")!(XOBMSG["WRITERR")!(XOBMSG["SYSERR") DO HALT "RTN","XOBVLL",136,0) . DO ^%ZTER "RTN","XOBVLL",137,0) . IF $GET(DUZ) DO CLEAN^XOBSCAV1 "RTN","XOBVLL",138,0) ; "RTN","XOBVLL",139,0) ; -- send error back to client "RTN","XOBVLL",140,0) USE XOBPORT "RTN","XOBVLL",141,0) DO ERROR^XOBVLIB(.XOBDAT) "RTN","XOBVLL",142,0) ; "RTN","XOBVLL",143,0) ; -- just quit if no slots are available or logins are disabled "RTN","XOBVLL",144,0) IF (XOBEC=181003)!(XOBEC=181004) QUIT "RTN","XOBVLL",145,0) ; "RTN","XOBVLL",146,0) ; -- need to make sure any locks are released since code aborted ungracefully "RTN","XOBVLL",147,0) LOCK "RTN","XOBVLL",148,0) ; "RTN","XOBVLL",149,0) ; -- Save off the error "RTN","XOBVLL",150,0) DO ^%ZTER "RTN","XOBVLL",151,0) ; "RTN","XOBVLL",152,0) ; -- go back to listening "RTN","XOBVLL",153,0) SET $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" DO KILL^XOBVLL G NXTCALLQ^XOBVLL",$ECODE=",U99," "RTN","XOBVLL",154,0) QUIT "RTN","XOBVLL",155,0) ; "RTN","XOBVLL",156,0) KILL ; -- new VistALink variables and then do big KILL "RTN","XOBVLL",157,0) NEW XOBPORT,XOBSTOP,XOBNULL,XOBOS,XOBSYS,XOBHDLR,XOBOK "RTN","XOBVLL",158,0) DO KILL^XUSCLEAN "RTN","XOBVLL",159,0) QUIT "RTN","XOBVLL",160,0) ; "RTN","XOBVRH") 0^20^B13028891 "RTN","XOBVRH",1,0) XOBVRH ;mjk/alb SC/JDA - VistaLink Request Handler Utilities ;13APR2009 "RTN","XOBVRH",2,0) ;;1.5;VistALink;**MSC**;Sep 09, 2005 "RTN","XOBVRH",3,0) ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026] "RTN","XOBVRH",4,0) ; "RTN","XOBVRH",5,0) QUIT "RTN","XOBVRH",6,0) ; "RTN","XOBVRH",7,0) ; ------------------------------------------------------------------ "RTN","XOBVRH",8,0) ; Message Type Handler Utilities "RTN","XOBVRH",9,0) ; ------------------------------------------------------------------ "RTN","XOBVRH",10,0) ; "RTN","XOBVRH",11,0) ; -- set up msg type info using message name "RTN","XOBVRH",12,0) MSGNAME(XOBMSG,XOBHDLR) ; -- set up msg type info "RTN","XOBVRH",13,0) QUIT $$SETMSG(XOBMSG,"NAME",.XOBHDLR) "RTN","XOBVRH",14,0) ; "RTN","XOBVRH",15,0) ; -- set up msg type info using message type "RTN","XOBVRH",16,0) MSGTYPE(XOBMSG,XOBHDLR) ; -- set up msg type info "RTN","XOBVRH",17,0) QUIT $$SETMSG(XOBMSG,"MSGTYPE",.XOBHDLR) "RTN","XOBVRH",18,0) ; "RTN","XOBVRH",19,0) ; -- set up msg type info using proprietary string "RTN","XOBVRH",20,0) MSGSINK(XOBMSG,XOBHDLR) ; -- set up msg type info "RTN","XOBVRH",21,0) QUIT $$SETMSG(XOBMSG,"D",.XOBHDLR) "RTN","XOBVRH",22,0) ; "RTN","XOBVRH",23,0) CACHE(XOBHDLR) ; -- cache req handlers "RTN","XOBVRH",24,0) NEW TYPE,TYPE0,XOBOK "RTN","XOBVRH",25,0) SET TYPE=0 "RTN","XOBVRH",26,0) SET XOBOK=1 "RTN","XOBVRH",27,0) ; "RTN","XOBVRH",28,0) ; -- load request handler info "RTN","XOBVRH",29,0) FOR SET TYPE=$ORDER(^XOB(18.05,"AS",1,TYPE)) QUIT:'TYPE DO QUIT:'XOBOK "RTN","XOBVRH",30,0) . SET TYPE0=$GET(^XOB(18.05,TYPE,0)) "RTN","XOBVRH",31,0) . DO SET(TYPE,TYPE0,.XOBHDLR) "RTN","XOBVRH",32,0) . SET XOBOK=$GET(XOBHDLR(TYPE)) "RTN","XOBVRH",33,0) . IF 'XOBOK SET XOBOK=XOBOK_U_$GET(XOBHDLR,"ERROR") "RTN","XOBVRH",34,0) QUIT XOBOK "RTN","XOBVRH",35,0) ; "RTN","XOBVRH",36,0) ; "RTN","XOBVRH",37,0) GTM(XOBHDLR) ; -- GT.M req handlers "RTN","XOBVRH",38,0) Q $$CACHE(.XOBHDLR) ; Same as Cache until something different is needed "RTN","XOBVRH",39,0) ; "RTN","XOBVRH",40,0) ; -- set up msg type info "RTN","XOBVRH",41,0) SETMSG(XOBMSG,XOBXREF,XOBHDLR) ; "RTN","XOBVRH",42,0) NEW TYPE,TYPEO "RTN","XOBVRH",43,0) KILL XOBHDLR(0) "RTN","XOBVRH",44,0) ; "RTN","XOBVRH",45,0) ; -- already cached? "RTN","XOBVRH",46,0) SET TYPE=$ORDER(XOBHDLR(XOBXREF,XOBMSG,"")) "RTN","XOBVRH",47,0) IF TYPE QUIT TYPE "RTN","XOBVRH",48,0) ; "RTN","XOBVRH",49,0) ; -- load req handler "RTN","XOBVRH",50,0) SET TYPE=+$ORDER(^XOB(18.05,XOBXREF,XOBMSG,"")) "RTN","XOBVRH",51,0) IF TYPE DO "RTN","XOBVRH",52,0) . SET TYPE0=$GET(^XOB(18.05,TYPE,0)) "RTN","XOBVRH",53,0) . DO SET(.TYPE,.TYPE0,.XOBHDLR) "RTN","XOBVRH",54,0) IF 'TYPE DO "RTN","XOBVRH",55,0) . SET XOBHDLR(0)=0 "RTN","XOBVRH",56,0) . SET XOBHDLR(0,"ERROR")="No message type defined" "RTN","XOBVRH",57,0) QUIT TYPE "RTN","XOBVRH",58,0) ; "RTN","XOBVRH",59,0) SET(TYPE,TYPE0,XOBHDLR) ; -- set nodes "RTN","XOBVRH",60,0) NEW IRTN,XOBICBK "RTN","XOBVRH",61,0) KILL XOBHDLR(TYPE) "RTN","XOBVRH",62,0) SET IRTN=$$IRTN(TYPE0) "RTN","XOBVRH",63,0) IF IRTN="" DO GOTO SETQ "RTN","XOBVRH",64,0) . SET XOBHDLR(TYPE)=0 "RTN","XOBVRH",65,0) . IF TYPE0="" SET XOBHDLR(TYPE,"ERROR")="No entry for message type ["_TYPE_"]" QUIT "RTN","XOBVRH",66,0) . IF IRTN="" SET XOBHDLR(TYPE,"ERROR")="Invalid interface routine specified ["_$PIECE(TYPE0,U,5)_"]" QUIT "RTN","XOBVRH",67,0) ; "RTN","XOBVRH",68,0) SET XOBHDLR(TYPE)=1 "RTN","XOBVRH",69,0) SET XOBHDLR(TYPE,"AUTHENTICATE")=+$PIECE(TYPE0,U,4) "RTN","XOBVRH",70,0) SET XOBHDLR(TYPE,"REQHDLR")="DO REQHDLR^"_IRTN_"(.XOBDATA)" "RTN","XOBVRH",71,0) SET XOBHDLR(TYPE,"READER")="DO READER^"_IRTN_"(.XOBX,.XOBDATA)" "RTN","XOBVRH",72,0) IF $PIECE(TYPE0,U,1)]"" SET XOBHDLR("NAME",$PIECE(TYPE0,U,1),TYPE)="" "RTN","XOBVRH",73,0) IF $PIECE(TYPE0,U,2)]"" SET XOBHDLR("MSGTYPE",$PIECE(TYPE0,U,2),TYPE)="" "RTN","XOBVRH",74,0) IF $PIECE(TYPE0,U,7)]"" SET XOBHDLR("D",$PIECE(TYPE0,U,7),TYPE)="" "RTN","XOBVRH",75,0) ; "RTN","XOBVRH",76,0) ; -- set up SAX callbacks "RTN","XOBVRH",77,0) SET XOBHDLR(TYPE,"CB","ELEST")="QUIT" "RTN","XOBVRH",78,0) SET XOBHDLR(TYPE,"CB","ELEND")="QUIT" "RTN","XOBVRH",79,0) SET XOBHDLR(TYPE,"CB","CHR")="QUIT" "RTN","XOBVRH",80,0) ; "RTN","XOBVRH",81,0) XECUTE "DO CALLBACK^"_IRTN_"(.XOBICBK)" "RTN","XOBVRH",82,0) IF $DATA(XOBICBK("STARTELEMENT")) SET XOBHDLR(TYPE,"CB","ELEST")="DO "_XOBICBK("STARTELEMENT")_"(.ELE,.ATR)" "RTN","XOBVRH",83,0) IF $DATA(XOBICBK("ENDELEMENT")) SET XOBHDLR(TYPE,"CB","ELEND")="DO "_XOBICBK("ENDELEMENT")_"(.ELE)" "RTN","XOBVRH",84,0) IF $DATA(XOBICBK("CHARACTERS")) SET XOBHDLR(TYPE,"CB","CHR")="DO "_XOBICBK("CHARACTERS")_"(.TXT)" "RTN","XOBVRH",85,0) SETQ ; "RTN","XOBVRH",86,0) QUIT "RTN","XOBVRH",87,0) ; "RTN","XOBVRH",88,0) ; -- get interface routine and test for existence "RTN","XOBVRH",89,0) IRTN(XOBTYPE0) ; "RTN","XOBVRH",90,0) NEW X,RTN "RTN","XOBVRH",91,0) SET RTN="" "RTN","XOBVRH",92,0) SET X=$PIECE(XOBTYPE0,"^",5) "RTN","XOBVRH",93,0) IF X]"" DO "RTN","XOBVRH",94,0) . XECUTE ^%ZOSF("TEST") "RTN","XOBVRH",95,0) . IF $TEST SET RTN=X "RTN","XOBVRH",96,0) QUIT RTN "RTN","XOBVRH",97,0) ; "RTN","XOBVSKT") 0^21^B19755798 "RTN","XOBVSKT",1,0) XOBVSKT ;; mjk/alb MSC/JDA- VistaLink Socket Methods ;13APR2009 "RTN","XOBVSKT",2,0) ;;1.5;VistALink;**MSC**;Sep 09, 2005 "RTN","XOBVSKT",3,0) ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026] "RTN","XOBVSKT",4,0) ; "RTN","XOBVSKT",5,0) QUIT "RTN","XOBVSKT",6,0) ; "RTN","XOBVSKT",7,0) ; ------------------------------------------------------------------------------------ "RTN","XOBVSKT",8,0) ; Methods for Read fromto TCP/IP Socket "RTN","XOBVSKT",9,0) ; ------------------------------------------------------------------------------------ "RTN","XOBVSKT",10,0) READ(XOBROOT,XOBREAD,XOBTO,XOBFIRST,XOBSTOP,XOBDATA,XOBHDLR) ; "RTN","XOBVSKT",11,0) NEW X,EOT,OUT,STR,LINE,PIECES,DONE,TOFLAG,XOBCNT,XOBLEN,XOBBH,XOBEH,BS,ES,XOBOK,XOBX "RTN","XOBVSKT",12,0) ; "RTN","XOBVSKT",13,0) SET STR="",EOT=$CHAR(4),DONE=0,LINE=0,XOBOK=1 "RTN","XOBVSKT",14,0) ; "RTN","XOBVSKT",15,0) ; -- READ tcp stream to global buffer | main calling tag NXTCALL^XOBVLL "RTN","XOBVSKT",16,0) FOR READ XOBX#XOBREAD:XOBTO SET TOFLAG=$TEST DO:XOBFIRST CHK DO:'XOBSTOP!('DONE) QUIT:DONE "RTN","XOBVSKT",17,0) . ; "RTN","XOBVSKT",18,0) . ; -- if length of (new intake + current) is too large for buffer then store current "RTN","XOBVSKT",19,0) . IF $LENGTH(STR)+$LENGTH(XOBX)>400 DO ADD(STR) SET STR="" "RTN","XOBVSKT",20,0) . SET STR=STR_XOBX "RTN","XOBVSKT",21,0) . ; "RTN","XOBVSKT",22,0) . ; -- add node at each line-feed character "RTN","XOBVSKT",23,0) . ; COMMENTED OUT: Not needed anymore, and has side effect of stripping out line feeds in input "RTN","XOBVSKT",24,0) . ; array-type parameter values (in XML mode) "RTN","XOBVSKT",25,0) . ; FOR QUIT:STR'[$CHAR(10) DO ADD($PIECE(STR,$CHAR(10))) SET STR=$PIECE(STR,$CHAR(10),2,999) "RTN","XOBVSKT",26,0) . ; "RTN","XOBVSKT",27,0) . ; -- if end-of-text marker found then wrap up and quit "RTN","XOBVSKT",28,0) . IF STR[EOT SET STR=$PIECE(STR,EOT) DO ADD(STR) SET DONE=1 QUIT "RTN","XOBVSKT",29,0) . ; "RTN","XOBVSKT",30,0) . ; -- M XML parser cannot handle an element name split across nodes "RTN","XOBVSKT",31,0) . SET PIECES=$LENGTH(STR,">") "RTN","XOBVSKT",32,0) . IF PIECES>1 DO ADD($PIECE(STR,">",1,PIECES-1)_">") SET STR=$PIECE(STR,">",PIECES,999) "RTN","XOBVSKT",33,0) ; "RTN","XOBVSKT",34,0) QUIT XOBOK "RTN","XOBVSKT",35,0) ; "RTN","XOBVSKT",36,0) ADD(TXT) ; -- add new intake line "RTN","XOBVSKT",37,0) SET LINE=LINE+1 "RTN","XOBVSKT",38,0) SET @XOBROOT@(LINE)=TXT "RTN","XOBVSKT",39,0) QUIT "RTN","XOBVSKT",40,0) ; "RTN","XOBVSKT",41,0) CHK ; -- check if first read and change timeout and chars to read "RTN","XOBVSKT",42,0) SET XOBFIRST=0 "RTN","XOBVSKT",43,0) ; "RTN","XOBVSKT",44,0) ; -- abort if time out occurred and nothing was read "RTN","XOBVSKT",45,0) IF 'TOFLAG,$GET(XOBX)="" SET XOBSTOP=1,DONE=1,XOBOK=0 QUIT "RTN","XOBVSKT",46,0) ; "RTN","XOBVSKT",47,0) ; -- intercept for transport sinks "RTN","XOBVSKT",48,0) IF $EXTRACT(XOBX)'="<" DO SINK "RTN","XOBVSKT",49,0) ; "RTN","XOBVSKT",50,0) ; -- set up for subsequent reads "RTN","XOBVSKT",51,0) SET XOBREAD=200,XOBTO=1 "RTN","XOBVSKT",52,0) QUIT "RTN","XOBVSKT",53,0) ; "RTN","XOBVSKT",54,0) ; ------------------------------------------------------------------------------------ "RTN","XOBVSKT",55,0) ; Execute Proprietary Format Reader "RTN","XOBVSKT",56,0) ; ------------------------------------------------------------------------------------ "RTN","XOBVSKT",57,0) SINK ; "RTN","XOBVSKT",58,0) ; -- get size of sink indicator >> then get sink indicator >> load req handler "RTN","XOBVSKT",59,0) SET XOBHDLR=$$MSGSINK^XOBVRH($$GETSTR(+$$GETSTR(2,.XOBX),.XOBX),.XOBHDLR) "RTN","XOBVSKT",60,0) ; "RTN","XOBVSKT",61,0) ; -- execute proprietary stream reader "RTN","XOBVSKT",62,0) IF $GET(XOBHDLR(XOBHDLR)) XECUTE $GET(XOBHDLR(XOBHDLR,"READER")) "RTN","XOBVSKT",63,0) ; "RTN","XOBVSKT",64,0) SET DONE=1 "RTN","XOBVSKT",65,0) QUIT "RTN","XOBVSKT",66,0) ; "RTN","XOBVSKT",67,0) ; -- get string of length LEN from stream buffer "RTN","XOBVSKT",68,0) GETSTR(LEN,XOBUF) ; "RTN","XOBVSKT",69,0) NEW X "RTN","XOBVSKT",70,0) FOR QUIT:($LENGTH(XOBUF)'511 FLUSH WRITE STR QUIT "RTN","XOBVSKT",157,0) ; "RTN","XOBVSKT",158,0) ; -- handle a long string "RTN","XOBVSKT",159,0) DO FLUSH "RTN","XOBVSKT",160,0) FOR QUIT:'$LENGTH(STR) WRITE $EXTRACT(STR,1,511) DO FLUSH SET STR=$EXTRACT(STR,512,99999) "RTN","XOBVSKT",161,0) ; "RTN","XOBVSKT",162,0) QUIT "RTN","XOBVSKT",163,0) ; "RTN","XOBVSKT",164,0) POST ; -- send eot and flush socket buffer "RTN","XOBVSKT",165,0) DO WRITE($CHAR(4)) "RTN","XOBVSKT",166,0) DO FLUSH "RTN","XOBVSKT",167,0) QUIT "RTN","XOBVSKT",168,0) ; "RTN","XOBVSKT",169,0) FLUSH ; flush buffer "RTN","XOBVSKT",170,0) IF XOBOS="OpenM" WRITE ! QUIT "RTN","XOBVSKT",171,0) IF XOBOS="DSM" WRITE:$X>0 ! QUIT "RTN","XOBVSKT",172,0) IF XOBOS="GTM" WRITE # QUIT "RTN","XOBVSKT",173,0) QUIT "RTN","XOBVSKT",174,0) ; "RTN","XOBVTCPL") 0^22^B13492271 "RTN","XOBVTCPL",1,0) XOBVTCPL ;; mjk/alb MSC/JDA - VistALink TCP/IP Listener (Cache NT) ;18JUN2009 "RTN","XOBVTCPL",2,0) ;;1.5;VistALink;**MSC**;Sep 09, 2005 "RTN","XOBVTCPL",3,0) ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026] "RTN","XOBVTCPL",4,0) ; "RTN","XOBVTCPL",5,0) QUIT "RTN","XOBVTCPL",6,0) ; "RTN","XOBVTCPL",7,0) ; -- Important: Should always be JOBed using START^XOBVTCP "RTN","XOBVTCPL",8,0) LISTENER(XOBPORT,XOBCFG) ; -- Start Listener "RTN","XOBVTCPL",9,0) ; "RTN","XOBVTCPL",10,0) N OS "RTN","XOBVTCPL",11,0) S OS=$$GETOS^XOBVTCP() "RTN","XOBVTCPL",12,0) ; -- quit if not Cache for NT or GT.M "RTN","XOBVTCPL",13,0) IF (OS'="OpenM-NT")&(OS'["GT.M") QUIT "RTN","XOBVTCPL",14,0) ; "RTN","XOBVTCPL",15,0) NEW $ETRAP,$ESTACK SET $ETRAP="D ^%ZTER HALT" "RTN","XOBVTCPL",16,0) ; "RTN","XOBVTCPL",17,0) NEW X,POP,XOBDA,U,DTIME,DT,XOBIO "RTN","XOBVTCPL",18,0) SET U="^",DTIME=900,DT=$$DT^XLFDT() "RTN","XOBVTCPL",19,0) IF $GET(DUZ)="" NEW DUZ SET DUZ=.5,DUZ(0)="@" "RTN","XOBVTCPL",20,0) ; "RTN","XOBVTCPL",21,0) ; -- only start if not already started "RTN","XOBVTCPL",22,0) IF $$LOCK^XOBVTCP(XOBPORT) DO "RTN","XOBVTCPL",23,0) . IF $$OPEN(.XOBIO,XOBPORT,OS) DO "RTN","XOBVTCPL",24,0) . . ; -- listener started and now stopping "RTN","XOBVTCPL",25,0) . . SET IO=XOBIO "RTN","XOBVTCPL",26,0) . . DO CLOSE^%ZISTCP "RTN","XOBVTCPL",27,0) . . ; -- update status to 'stopped' "RTN","XOBVTCPL",28,0) . . DO UPDATE^XOBVTCP(XOBPORT,4,$GET(XOBCFG)) "RTN","XOBVTCPL",29,0) . ELSE DO "RTN","XOBVTCPL",30,0) . . ; -- listener failed to start "RTN","XOBVTCPL",31,0) . . ; -- update status to 'failed' "RTN","XOBVTCPL",32,0) . . DO UPDATE^XOBVTCP(XOBPORT,5,$GET(XOBCFG)) "RTN","XOBVTCPL",33,0) . ; "RTN","XOBVTCPL",34,0) . DO UNLOCK^XOBVTCP(XOBPORT) "RTN","XOBVTCPL",35,0) QUIT "RTN","XOBVTCPL",36,0) ; "RTN","XOBVTCPL",37,0) ; -- open/start listener port "RTN","XOBVTCPL",38,0) OPEN(XOBIO,XOBPORT,OS) ; "RTN","XOBVTCPL",39,0) Q $S(OS="OpenM-NT":$$OPENM(.XOBIO,XOBPORT),OS["GT.M":$$OPENGTM(.XOBIO,XOBPORT),1:0) "RTN","XOBVTCPL",40,0) ; "RTN","XOBVTCPL",41,0) ; -- open/start listener port on Cache "RTN","XOBVTCPL",42,0) OPENM(XOBIO,XOBPORT) ; "RTN","XOBVTCPL",43,0) NEW XOBBOX,%ZA "RTN","XOBVTCPL",44,0) SET XOBBOX=+$$GETBOX^XOBVTCP() "RTN","XOBVTCPL",45,0) SET XOBIO="|TCP|"_XOBPORT "RTN","XOBVTCPL",46,0) X "OPEN XOBIO:(:XOBPORT:""AT""):30" "RTN","XOBVTCPL",47,0) ; "RTN","XOBVTCPL",48,0) ; -- if listener port could not be openned then gracefully quit "RTN","XOBVTCPL",49,0) ; (other namespace using port maybe?) "RTN","XOBVTCPL",50,0) IF '$TEST QUIT 0 "RTN","XOBVTCPL",51,0) ; "RTN","XOBVTCPL",52,0) ; -- indicate listener is 'running' "RTN","XOBVTCPL",53,0) DO UPDATE^XOBVTCP(XOBPORT,2,$GET(XOBCFG)) "RTN","XOBVTCPL",54,0) ; -- read & spawn loop "RTN","XOBVTCPL",55,0) FOR DO QUIT:$$EXIT(XOBBOX,XOBPORT) "RTN","XOBVTCPL",56,0) . USE XOBIO "RTN","XOBVTCPL",57,0) . READ *X:60 IF '$TEST QUIT "RTN","XOBVTCPL",58,0) . X "JOB CHILD^XOBVTCPL:(:4:XOBIO:XOBIO):10" SET %ZA=$ZA "RTN","XOBVTCPL",59,0) . IF %ZA\8196#2=1 WRITE *-2 ;Job failed to clear bit "RTN","XOBVTCPL",60,0) QUIT 1 "RTN","XOBVTCPL",61,0) ; "RTN","XOBVTCPL",62,0) ; -- open/start listener port on GT.M "RTN","XOBVTCPL",63,0) OPENGTM(XOBIO,XOBPORT) ; "RTN","XOBVTCPL",64,0) NEW XOBBOX "RTN","XOBVTCPL",65,0) SET XOBBOX=+$$GETBOX^XOBVTCP() "RTN","XOBVTCPL",66,0) SET XOBIO="|TCP|"_XOBPORT_"|"_$J "RTN","XOBVTCPL",67,0) OPEN XOBIO:(ZLISTEN=XOBPORT_":TCP":ATTACH="LISTENER"):5:"SOCKET" "RTN","XOBVTCPL",68,0) ; "RTN","XOBVTCPL",69,0) ; -- if listener port could not be openned then gracefully quit "RTN","XOBVTCPL",70,0) ; (other namespace using port maybe?) "RTN","XOBVTCPL",71,0) IF '$TEST QUIT 0 "RTN","XOBVTCPL",72,0) ; "RTN","XOBVTCPL",73,0) ; -- indicate listener is 'running' "RTN","XOBVTCPL",74,0) DO UPDATE^XOBVTCP(XOBPORT,2,$GET(XOBCFG)) "RTN","XOBVTCPL",75,0) D LISTEN^ZISTCPS(XOBPORT,"CHILD^XOBVTCPL","EXIT^XOBVTCPL("_XOBBOX_","_XOBPORT_")") "RTN","XOBVTCPL",76,0) ; "RTN","XOBVTCPL",77,0) CHILD ;Child process "RTN","XOBVTCPL",78,0) NEW XOBEC "RTN","XOBVTCPL",79,0) SET $ETRAP="D ^%ZTER L HALT" "RTN","XOBVTCPL",80,0) SET IO=$PRINCIPAL ;Reset IO to be $P "RTN","XOBVTCPL",81,0) IF $$GETOS^XOBVTCP()["OpenM" X "USE IO:(::""-M"")" ;Packet mode like DSM "RTN","XOBVTCPL",82,0) ; -- do quit to save a stack level "RTN","XOBVTCPL",83,0) SET XOBEC=$$NEWOK() "RTN","XOBVTCPL",84,0) IF XOBEC DO LOGINERR(XOBEC,IO) "RTN","XOBVTCPL",85,0) IF 'XOBEC DO VAR,SPAWN^XOBVLL "RTN","XOBVTCPL",86,0) QUIT "RTN","XOBVTCPL",87,0) ; "RTN","XOBVTCPL",88,0) VAR ;Setup IO variables "RTN","XOBVTCPL",89,0) SET IO(0)=IO,IO(1,IO)="",POP=0 "RTN","XOBVTCPL",90,0) SET IOT="TCP",IOF="#",IOST="P-TCP",IOST(0)=0 "RTN","XOBVTCPL",91,0) QUIT "RTN","XOBVTCPL",92,0) ; "RTN","XOBVTCPL",93,0) NEWOK() ;Is it OK to start a new process "RTN","XOBVTCPL",94,0) NEW XQVOL,XUVOL,X,XOBCODE,Y "RTN","XOBVTCPL",95,0) SET U="^" "RTN","XOBVTCPL",96,0) DO GETENV^%ZOSV SET XQVOL=$PIECE(Y,U,2) "RTN","XOBVTCPL",97,0) SET X=$$FIND1^DIC(8989.304,",1,","BX",XQVOL,"","",""),XUVOL=$SELECT(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1") "RTN","XOBVTCPL",98,0) SET XOBCODE=$$INHIBIT^XUSRB() "RTN","XOBVTCPL",99,0) IF XOBCODE=1 QUIT 181004 "RTN","XOBVTCPL",100,0) IF XOBCODE=2 QUIT 181003 "RTN","XOBVTCPL",101,0) QUIT 0 "RTN","XOBVTCPL",102,0) ; "RTN","XOBVTCPL",103,0) ; -- process error "RTN","XOBVTCPL",104,0) LOGINERR(XOBEC,XOBPORT) ; "RTN","XOBVTCPL",105,0) DO ERROR^XOBVLL(XOBEC,$$EZBLD^DIALOG(XOBEC),XOBPORT) "RTN","XOBVTCPL",106,0) ; "RTN","XOBVTCPL",107,0) ; -- give client time to process stream "RTN","XOBVTCPL",108,0) HANG 2 "RTN","XOBVTCPL",109,0) QUIT "RTN","XOBVTCPL",110,0) ; "RTN","XOBVTCPL",111,0) EXIT(XOBBOX,XOBPORT) ; "RTN","XOBVTCPL",112,0) ; -- is status 'stopping' "RTN","XOBVTCPL",113,0) SET ZISQUIT=$PIECE($GET(^XOB(18.04,+$$GETLOGID(XOBBOX,XOBPORT),0)),U,3)=3 "RTN","XOBVTCPL",114,0) Q ZISQUIT "RTN","XOBVTCPL",115,0) ; "RTN","XOBVTCPL",116,0) GETLOGID(XOBBOX,XOBPORT) ; "RTN","XOBVTCPL",117,0) QUIT +$ORDER(^XOB(18.04,"C",XOBBOX,XOBPORT,"")) "RTN","XOBVTCPL",118,0) ; "RTN","XPDR") 0^26^B52133395 "RTN","XPDR",1,0) XPDR ;SFISC/RSD MSC/JDS - Routine File Edit ;24APR2009 "RTN","XPDR",2,0) ;;8.0;KERNEL;**1,2,44,MSC**;Jul 10, 1995 "RTN","XPDR",3,0) Q "RTN","XPDR",4,0) UPDT ;update routine file "RTN","XPDR",5,0) N DIR,DIRUT,XPD,XPDI,XPDJ,XPDN,X,X1,Y,Y1,% W ! "RTN","XPDR",6,0) W ! S DIR(0)="FO^1:9^K:X'?.1""-""1U.7UNP X",DIR("A")="Routine Namespace",DIR("?")="Enter 1 to 8 characters, preceed with ""-"" to exclude namespace" "RTN","XPDR",7,0) ;XPDN(0=excluded names or 1=include names, namespace)="" "RTN","XPDR",8,0) F D ^DIR Q:$D(DIRUT) S X=$E(Y,$L(Y))="*",%=$E(Y)="-",XPDN('%,$E(Y,%+1,$L(Y)-X))="" "RTN","XPDR",9,0) Q:'$D(XPDN)!$D(DTOUT)!$D(DUOUT) "RTN","XPDR",10,0) W !!,"NAMESPACE INCLUDE",?35,"EXCLUDE",!,?11,"-------",?35,"-------" "RTN","XPDR",11,0) S (X,Y)="",(X1,Y1)=1 "RTN","XPDR",12,0) F D W !?11,X,?35,Y Q:'X1&'Y1 "RTN","XPDR",13,0) .S:X1 X=$O(XPDN(1,X)),X1=X]"" S:Y1 Y=$O(XPDN(0,Y)),Y1=Y]"" "RTN","XPDR",14,0) K DIR S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR "RTN","XPDR",15,0) Q:'Y!$D(DIRUT) W ! "RTN","XPDR",16,0) S DIR(0)="Y",DIR("A")="Want me to clean up the Routine File before updating",DIR("?")="YES means you want to go throught the Routine file and delete any routine name that no longer exists on the system." "RTN","XPDR",17,0) D ^DIR "RTN","XPDR",18,0) Q:$D(DIRUT) D WAIT^DICD,DELRTN:Y "RTN","XPDR",19,0) ;loop thru include list XPDN(1,XPDI) "RTN","XPDR",20,0) N ISGTM S ISGTM=$G(^%ZOSF("OS"))["GT.M" "RTN","XPDR",21,0) S XPDI="" F S XPDI=$O(XPDN(1,XPDI)) Q:XPDI="" D "RTN","XPDR",22,0) .D:ISGTM SILENT^%RSEL("*") S XPDJ=XPDI D:$$ROUT(1,ISGTM,XPDJ) F S XPDJ=$$ROUT(0,ISGTM,XPDJ) Q:XPDJ=""!($P(XPDJ,XPDI)]"") D "RTN","XPDR",23,0) ..;if name XPDJ is in the exclude list, XPDN(0,XPDJ) or in Routine file, quit "RTN","XPDR",24,0) ..Q:$D(XPDN(0,XPDJ))!$O(^DIC(9.8,"B",XPDJ,0)) "RTN","XPDR",25,0) ..;check if XPDJ is refered in the namespace by checking the subscript "RTN","XPDR",26,0) ..;before XPDJ, if sub exist and $P(XPDJ,sub)="" then it is part of the "RTN","XPDR",27,0) ..;namespace, quit "RTN","XPDR",28,0) ..S %=$O(XPDN(0,XPDJ),-1) I $L(%),$P(XPDJ,%)="" Q "RTN","XPDR",29,0) ..N XPD S XPD(9.8,"+1,",.01)=XPDJ,XPD(9.8,"+1,",1)="R" "RTN","XPDR",30,0) ..D ADD^DICA("","XPD") "RTN","XPDR",31,0) W " ...Done.",! "RTN","XPDR",32,0) Q "RTN","XPDR",33,0) ROUT(D,ISGTM,VALUE) ; "RTN","XPDR",34,0) I D,ISGTM Q $D(%ZR(VALUE)) "RTN","XPDR",35,0) I ISGTM Q $O(%ZR(VALUE)) "RTN","XPDR",36,0) N A I D X "S X=$D(^$R(VALUE))" Q A "RTN","XPDR",37,0) X "S A=$O(^$R(VALUE))" Q A "RTN","XPDR",38,0) VER ;verify Routine file "RTN","XPDR",39,0) N DIR,DIRUT,X,Y "RTN","XPDR",40,0) W !,"I will delete all entries in the Routine File in which",!,"the Routine no longer exist on this system!",! "RTN","XPDR",41,0) S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR "RTN","XPDR",42,0) Q:'Y!$D(DIRUT) D DELRTN "RTN","XPDR",43,0) W " ...Done.",! "RTN","XPDR",44,0) Q "RTN","XPDR",45,0) DELRTN ;delete routine file entries "RTN","XPDR",46,0) N DA,DIK,Y "RTN","XPDR",47,0) S DIK="^DIC(9.8,",DA=0 "RTN","XPDR",48,0) F S DA=$O(^DIC(9.8,DA)) Q:'DA S Y=$G(^(DA,0)) I $P(Y,U,2)="R",$T(^@$P(Y,U))="" D ^DIK "RTN","XPDR",49,0) Q "RTN","XPDR",50,0) PURGE ;purge file "RTN","XPDR",51,0) N DA,DIK,DIR,DIRUT,X,XPD,XPDF,XPDI,XPDJ,XPDL,XPDN,XPDPG,XPDS,XPDUL,Y,Z "RTN","XPDR",52,0) S DIR("?")="Enter the file you want to purge the data from.",DIR(0)="SM^B:Build;I:Install;ALL:Build & Install",DIR("A")="Purge from what file(s)" "RTN","XPDR",53,0) D ^DIR Q:$D(DIRUT) "RTN","XPDR",54,0) S XPDF=$S(Y="I":9.7,1:9.6) S:Y="ALL" XPDF(1)=9.7 "RTN","XPDR",55,0) K DIR S DIR("?")="Enter the number of Versions to keep in the file, for each package",DIR(0)="N^0:100:0",DIR("A")="Versions to Retain",DIR("B")=1 "RTN","XPDR",56,0) D ^DIR Q:$D(DIRUT) S XPDN=Y "RTN","XPDR",57,0) K DIR "RTN","XPDR",58,0) S DIR(0)="FO^3:30",DIR("?")="^D PURGEH^XPDR",DIR("A")="Package Name",DIR("B")="ALL" "RTN","XPDR",59,0) F D ^DIR Q:$D(DIRUT) S XPD(X)="" Q:X="ALL" K DIR("B") S DIR("A")="Another Package Name" "RTN","XPDR",60,0) Q:'$D(XPD) "RTN","XPDR",61,0) ;if they want all, make sure all is the only one "RTN","XPDR",62,0) I $D(XPD("ALL")) K XPD S XPD("ALL")="" "RTN","XPDR",63,0) ;XPDF(1) is defined if doing both files, do purge twice "RTN","XPDR",64,0) K ^TMP($J) D PURGE1(XPDF),PURGE1($G(XPDF(1))):$D(XPDF(1)) "RTN","XPDR",65,0) I '$D(^TMP($J)) W !!,"No match found" Q "RTN","XPDR",66,0) K XPD,DIR "RTN","XPDR",67,0) S DIR(0)="E",$P(XPDUL,"-",IOM)="" "RTN","XPDR",68,0) ;if ALL, reset XPDF to next file and Do, then reset back to 9.6 "RTN","XPDR",69,0) D I $D(XPDF(1)) D ^DIR I Y S XPDF=XPDF(1) D S XPDF=9.6 "RTN","XPDR",70,0) .S XPD="^TMP("_$J_","_XPDF,XPDS=XPD_",",XPD=XPD_")",XPDL=$L(XPDS),XPDPG=1,Y=1 "RTN","XPDR",71,0) .W @IOF D HDR "RTN","XPDR",72,0) .;loop thru ^TMP($J,file,package) & show list, quit if user "^" "RTN","XPDR",73,0) .F S XPD=$Q(@XPD) Q:XPD=""!($E(XPD,1,XPDL)'=XPDS) D Q:'Y "RTN","XPDR",74,0) ..S Z=@XPD W $P(Z,"^"),$S($P(Z,"^",3):" (duplicates)",1:""),! Q:$Y<(IOSL-4) "RTN","XPDR",75,0) ..D ^DIR Q:'Y "RTN","XPDR",76,0) ..S XPDPG=XPDPG+1 W @IOF D HDR "RTN","XPDR",77,0) S DIR(0)="Y",DIR("A")="OK to DELETE these entries",DIR("B")="NO" "RTN","XPDR",78,0) W !! D ^DIR "RTN","XPDR",79,0) I $D(DIRUT)!'Y W !!,"Nothing Purged" Q "RTN","XPDR",80,0) ;loop thru and delete "RTN","XPDR",81,0) D I $D(XPDF(1)) S XPDF=XPDF(1) D "RTN","XPDR",82,0) .S DIK="^XPD("_XPDF_",",XPD="^TMP("_$J_","_XPDF,XPDS=XPD_",",XPD=XPD_")",XPDL=$L(XPDS) "RTN","XPDR",83,0) .F S XPD=$Q(@XPD) Q:XPD=""!($E(XPD,1,XPDL)'=XPDS) D "RTN","XPDR",84,0) ..S XPDI=@XPD F XPDJ=2:1 S DA=$P(XPDI,"^",XPDJ) Q:'DA D ^DIK "RTN","XPDR",85,0) Q "RTN","XPDR",86,0) ; "RTN","XPDR",87,0) PURGE1(XPDF) ;XPDF=file # "RTN","XPDR",88,0) N XPDFL,XPDI,XPDJ,XPDP,XPDV,Y,Z "RTN","XPDR",89,0) W "." "RTN","XPDR",90,0) ;if All, loop thru B x-ref "RTN","XPDR",91,0) I $D(XPD("ALL")) D "RTN","XPDR",92,0) .S XPDI="" "RTN","XPDR",93,0) .F S XPDI=$O(^XPD(XPDF,"B",XPDI)) Q:XPDI="" D "RTN","XPDR",94,0) ..S X=$$PKG^XPDUTL(XPDI) D PURGE2(X) "RTN","XPDR",95,0) ..W "." "RTN","XPDR",96,0) E S XPDI="" F S XPDI=$O(XPD(XPDI)) Q:XPDI="" D "RTN","XPDR",97,0) .D PURGE2(XPDI) "RTN","XPDR",98,0) .W "." "RTN","XPDR",99,0) ;loop thru each package, XPDP=package name "RTN","XPDR",100,0) S XPDP="" F S XPDP=$O(^TMP($J,XPDF,XPDP)) Q:XPDP="" D "RTN","XPDR",101,0) .S XPDV="",XPDL=XPDN "RTN","XPDR",102,0) .;the last is the most recent, XPDN = number to retain, XPDV=version "RTN","XPDR",103,0) .;XPDS=type (T/V/Z) "RTN","XPDR",104,0) .F S XPDV=$O(^TMP($J,XPDF,XPDP,XPDV),-1),XPDS="" Q:'XPDV!'XPDL F S XPDS=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS),-1) Q:XPDS=""!'XPDL D "RTN","XPDR",105,0) ..S Y="" F S Y=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y),-1) Q:Y=""!'XPDL D "RTN","XPDR",106,0) ...I $D(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y))#2 K ^(Y) S XPDL=XPDL-1 Q "RTN","XPDR",107,0) ...S Z="" F S Z=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y,Z),-1) Q:Z=""!'XPDL K ^(Z) S XPDL=XPDL-1 "RTN","XPDR",108,0) Q "RTN","XPDR",109,0) ; "RTN","XPDR",110,0) PURGE2(XPDX) ;XPDX=package name "RTN","XPDR",111,0) ;XPDFL=1 this is not a patch, quit when we find a patch during loop "RTN","XPDR",112,0) S XPDS=XPDX,XPDL=$L(XPDX),XPDFL=XPDX'["*" "RTN","XPDR",113,0) ;loop and find matches "RTN","XPDR",114,0) D F S XPDS=$O(^XPD(XPDF,"B",XPDS)) Q:XPDS=""!($E(XPDS,1,XPDL)'=XPDX)!($S(XPDFL:XPDS["*",1:0)) D "RTN","XPDR",115,0) .S Y=$O(^XPD(XPDF,"B",XPDS,0)) Q:'Y "RTN","XPDR",116,0) .Q:'$D(^XPD(XPDF,Y,0)) S Z=^(0),Y=XPDS_"^"_Y "RTN","XPDR",117,0) .;can't delete Installs that status isn't 'Install Completed' "RTN","XPDR",118,0) .I XPDF=9.7 Q:$P(Z,U,9)<3 "RTN","XPDR",119,0) .S XPDV=$$VER^XPDUTL(XPDS) "RTN","XPDR",120,0) .;TMP($J,file,package name,version,"*","T/V/Z",num,patch)=NAME^DA^duplicat DAs "RTN","XPDR",121,0) .I XPDS["*" D Q "RTN","XPDR",122,0) ..I XPDV?1.2N1"."1.2N S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*Z",0,+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q "RTN","XPDR",123,0) ..I XPDV["T" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*T",+$P(XPDV,"T",2),+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q "RTN","XPDR",124,0) ..I XPDV["V" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*V",+$P(XPDV,"V",2),+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q "RTN","XPDR",125,0) ..S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*",+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) "RTN","XPDR",126,0) .;TMP($J,file,package name,version,"Z",0)=NAME^DA^duplicate DAs "RTN","XPDR",127,0) .I XPDV?1.2N1"."1.2N S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"Z",0)=Y_$$DUP(XPDS,$P(Y,"^",2)) Q "RTN","XPDR",128,0) .;TMP($J,file,package name,version,"T/V",num)=NAME^DA^dup DAs "RTN","XPDR",129,0) .I XPDV["T" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"T",+$P(XPDV,"T",2))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q "RTN","XPDR",130,0) .I XPDV["V" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"V",+$P(XPDV,"V",2))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q "RTN","XPDR",131,0) Q "RTN","XPDR",132,0) PURGEH ;executable help from DIR call at PURGE+8 "RTN","XPDR",133,0) W:$E(DIR("A"),1)="P" !,"Enter 'ALL' to purge all packages, or" "RTN","XPDR",134,0) W !,"Enter the name of the Package you want to Purge.",!," i.e. KERNEL 8.0 will purge version 8.0Tx and 8.0Vx",!," XU*8.0 will purge all patches for 8.0",! "RTN","XPDR",135,0) N DIR,X,Y "RTN","XPDR",136,0) S DIR(0)="Y",DIR("A")="Want to see the "_$S(XPDF=9.7:"Install File",$D(XPDF(1)):"Build & Install Files",1:"Build File")_" List",DIR("B")="Y" "RTN","XPDR",137,0) D ^DIR Q:'Y!$D(DIRUT) "RTN","XPDR",138,0) D PURGEH1("^XPD(9.6,"):XPDF=9.6,PURGEH1("^XPD(9.7,"):XPDF=9.7!$D(XPDF(1)) "RTN","XPDR",139,0) Q "RTN","XPDR",140,0) ; "RTN","XPDR",141,0) DUP(Z,Z1) ;find duplicate, Z=NAME, Z1=last ien "RTN","XPDR",142,0) ;returns Y=DA^dup DA^dup DA... "RTN","XPDR",143,0) N Y S Y="" "RTN","XPDR",144,0) F S Z1=$O(^XPD(XPDF,"B",Z,Z1)) Q:'Z1 S Y=Y_"^"_Z1 "RTN","XPDR",145,0) Q Y "RTN","XPDR",146,0) ; "RTN","XPDR",147,0) PURGEH1(DIC) ; "RTN","XPDR",148,0) W !!,$S(DIC[9.6:"BUILD ",1:"INSTALL ")_"File" "RTN","XPDR",149,0) S DIC(0)="QE",X="??" D ^DIC "RTN","XPDR",150,0) Q "RTN","XPDR",151,0) ; "RTN","XPDR",152,0) HDR W !,"Package(s) in ",$S(XPDF=9.7:"INSTALL",1:"BUILD")," File, " "RTN","XPDR",153,0) I XPDN W "Retain last ",$S(XPDN=1:"version",1:XPDN_" versions") "RTN","XPDR",154,0) E W "Don't retain any versions" "RTN","XPDR",155,0) W ?70,"PAGE ",XPDPG,!,XPDUL,! "RTN","XPDR",156,0) Q "RTN","XQALSUR1") 0^42^B29675685 "RTN","XQALSUR1",1,0) XQALSUR1 ;ISC-SF.SEA/JLI,MSC/JDA - SURROGATES FOR ALERTS ;27APR2009 "RTN","XQALSUR1",2,0) ;;8.0;KERNEL;**366,MSC**;Jul 10, 1995 "RTN","XQALSUR1",3,0) Q "RTN","XQALSUR1",4,0) ; "RTN","XQALSUR1",5,0) RETURN(XQAUSER) ; P366 - return alerts to the user "RTN","XQALSUR1",6,0) N XQAI,X0,XQASTRT,XQASURO,XQAEND "RTN","XQALSUR1",7,0) ; identify periods in the surrogate multiple that haven't been returned "RTN","XQALSUR1",8,0) F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"AC",1,XQAI)) Q:XQAI'>0 S X0=^XTV(8992,XQAUSER,2,XQAI,0) I $P(X0,U,4)=1 D "RTN","XQALSUR1",9,0) . S XQASTRT=$P(X0,U) S XQAEND=$P(X0,U,3) "RTN","XQALSUR1",10,0) . ; and clear the flag indicating we need to restore these alerts "RTN","XQALSUR1",11,0) . N XQAFDA S XQAFDA(8992.02,XQAI_","_XQAUSER_",",.04)="@" D FILE^DIE("","XQAFDA") "RTN","XQALSUR1",12,0) . ; restore alerts to intended user, remove from surrogate if completed (i.e., no other surrogates and not intended recipient) "RTN","XQALSUR1",13,0) . D PUSHBACK(XQAUSER,XQASTRT,XQAEND) "RTN","XQALSUR1",14,0) . Q "RTN","XQALSUR1",15,0) Q "RTN","XQALSUR1",16,0) ; "RTN","XQALSUR1",17,0) PUSHBACK(XQAUSER,XQASTRT,XQAEND) ; P366 - identify alerts in alert tracking file for return and return them "RTN","XQALSUR1",18,0) N XQAINIT,XQAI,X0,X30,XNOSURO,XQADT,XQAJ,XQAK,XQAL,XQAOTH,XQASUROP "RTN","XQALSUR1",19,0) S XQAINIT=$$FIND1^DIC(8992.2,,"X","INITIAL RECIPIENT") "RTN","XQALSUR1",20,0) F XQADT=XQASTRT-.0000001:0 S XQADT=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT)) Q:XQADT'>0 Q:XQADT>XQAEND F XQAI=0:0 S XQAI=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT,XQAI)) Q:XQAI'>0 D "RTN","XQALSUR1",21,0) . S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQAUSER,0)) Q:XQAJ'>0 "RTN","XQALSUR1",22,0) . N XSURO,XNOSURO,XQAID S XNOSURO=0,XQAID=$P(^XTV(8992.1,XQAI,0),U) "RTN","XQALSUR1",23,0) . F XQAK=0:0 S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 D "RTN","XQALSUR1",24,0) . . S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) S:$P(X0,U,2)>0 XSURO($P(X0,U,2))="" S:$P(X0,U,2)'>0 XNOSURO=1 ; sent to XSURO as surrogate "RTN","XQALSUR1",25,0) . . Q "RTN","XQALSUR1",26,0) . I 'XNOSURO D "RTN","XQALSUR1",27,0) . . N XQA,XQACMNT,XQALTYPE "RTN","XQALSUR1",28,0) . . S XQA(XQAUSER)="",XQACMNT="RESTORED FROM SURROGATE",XQALTYPE="RESTORE FROM SURROGATE" "RTN","XQALSUR1",29,0) . . N XQAUSER,XQAI S XQAUSER=$O(^XTV(8992,"AXQA",XQAID,0)) Q:XQAUSER'>0 D RESETUP^XQALFWD(XQAID,.XQA,XQACMNT) "RTN","XQALSUR1",30,0) . . Q "RTN","XQALSUR1",31,0) . ; walk through each of those it was sent to as a surrogate for XQAUSER "RTN","XQALSUR1",32,0) . F XQASUROP=0:0 S XQASUROP=$O(XSURO(XQASUROP)) Q:XQASUROP'>0 S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQASUROP,0)) D "RTN","XQALSUR1",33,0) . . ; and identify each time they were considered a recipient of the alert "RTN","XQALSUR1",34,0) . . S XNOSURO=0 F XQAK=0:0 Q:XNOSURO S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) D Q:XNOSURO "RTN","XQALSUR1",35,0) . . . I $P(X0,U,3)'="Y" S XNOSURO=1 Q ; this one got it directly as a recipient as well "RTN","XQALSUR1",36,0) . . . ; walk through the SURROGATE FOR entries for this user "RTN","XQALSUR1",37,0) . . . F XQAOTH=0:0 S XQAOTH=$O(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH)) Q:XQAOTH'>0 S X30=^(XQAOTH,0) D Q:XNOSURO "RTN","XQALSUR1",38,0) . . . . I +X30=XQAUSER S $P(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH,0),U,3)=$$NOW^XLFDT() Q ; mark this user as returned "RTN","XQALSUR1",39,0) . . . . I $P(X30,U,3)'>0 S XNOSURO=1 Q ; another surrogate hasn't been returned yet, so leave the alert "RTN","XQALSUR1",40,0) . . . . Q "RTN","XQALSUR1",41,0) . . . Q "RTN","XQALSUR1",42,0) . . I 'XNOSURO D "RTN","XQALSUR1",43,0) . . . N XQAKILL,XQAUSER,XQAI S XQAKILL=1,XQAUSER=XQASUROP D DELETE^XQALDEL "RTN","XQALSUR1",44,0) . . . Q "RTN","XQALSUR1",45,0) . . Q "RTN","XQALSUR1",46,0) . Q "RTN","XQALSUR1",47,0) Q "RTN","XQALSUR1",48,0) ; "RTN","XQALSUR1",49,0) SUROLIST(XQAUSER,XQALIST) ; returns for XQAUSER a list of current and/or future surrogates in XQALIST "RTN","XQALSUR1",50,0) ; usage D SUROLIST^XQALSUR1(DUZ,.XQALIST) "RTN","XQALSUR1",51,0) ; "RTN","XQALSUR1",52,0) ; returns XQALIST=count "RTN","XQALSUR1",53,0) ; XQALIST(1)=IEN2^NEWPERSON,USER2^STARTDATETIME^ENDDATETIME "RTN","XQALSUR1",54,0) ; XQALIST(2)=3^NAME,USER3^3050407.1227^3050406 "RTN","XQALSUR1",55,0) ; "RTN","XQALSUR1",56,0) N XQA0,XQADATE,XQAIEN,XQAL,XQALCNT,XQALEND,XQANOW,XQASTART,XQASURO,XQAVALU "RTN","XQALSUR1",57,0) D CHEKSUBS^XQALSUR2(XQAUSER) "RTN","XQALSUR1",58,0) S XQALCNT=$$CURRSURO^XQALSURO(XQAUSER) "RTN","XQALSUR1",59,0) S XQANOW=$$NOW^XLFDT(),XQALCNT=0 "RTN","XQALSUR1",60,0) S XQADATE="" F S XQADATE=$O(^XTV(8992,XQAUSER,2,"B",XQADATE)) Q:XQADATE'>0 S XQAIEN="" F S XQAIEN=$O(^XTV(8992,XQAUSER,2,"B",XQADATE,XQAIEN)) Q:XQAIEN'>0 D "RTN","XQALSUR1",61,0) . S XQA0=^XTV(8992,XQAUSER,2,XQAIEN,0),XQASTART=$P(XQA0,U),XQASURO=$P(XQA0,U,2),XQALEND=$P(XQA0,U,3) I XQALEND>0,XQALEND'>XQANOW Q "RTN","XQALSUR1",62,0) . S XQALCNT=XQALCNT+1,XQAVALU=$$GET1^DIQ(200,XQASURO_",",.01),XQAL(XQALCNT)=XQASURO_U_XQAVALU_U_XQASTART_U_XQALEND "RTN","XQALSUR1",63,0) . Q "RTN","XQALSUR1",64,0) ; now rearrange by earliest to last "RTN","XQALSUR1",65,0) K XQALIST S XQALIST=0 "RTN","XQALSUR1",66,0) S XQALCNT="" F S XQALCNT=$O(XQAL(XQALCNT)) Q:XQALCNT'>0 D "RTN","XQALSUR1",67,0) . ; if end date not specified, and start date follows, set end date to next start date "RTN","XQALSUR1",68,0) . I $D(XQAL(XQALCNT+1)),($P(XQAL(XQALCNT),U,4)>$P(XQAL(XQALCNT+1),U,3))!($P(XQAL(XQALCNT),U,4)'>0) S $P(XQAL(XQALCNT),U,4)=$P(XQAL(XQALCNT+1),U,3) "RTN","XQALSUR1",69,0) . S XQALIST=XQALIST+1,XQALIST(XQALIST)=XQAL(XQALCNT) "RTN","XQALSUR1",70,0) . Q "RTN","XQALSUR1",71,0) Q "RTN","XQALSUR1",72,0) ; "RTN","XQALSUR1",73,0) DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND) ; code added to prevent cyclical surrogates - use dates for surrogacy "RTN","XQALSUR1",74,0) N XQALNEXT,XQALIST,I,XQALAST "RTN","XQALSUR1",75,0) I XQALSURO=XQAUSER Q "This forms a circle which leads back to this user during this period - can't do it!" "RTN","XQALSUR1",76,0) S XQALNEXT=$$CURRSURO^XQALSURO(XQALSURO,XQALSTRT,XQALEND) I XQALNEXT>0 D "RTN","XQALSUR1",77,0) . F I=1:1 Q:$P(XQALNEXT,U,I)="" S XQALAST=$$DCYCLIC($P(XQALNEXT,U,I),XQAUSER,XQALSTRT,XQALEND) I XQALAST'>0 S XQALSURO=XQALAST Q "RTN","XQALSUR1",78,0) . Q "RTN","XQALSUR1",79,0) Q XQALSURO "RTN","XQALSUR1",80,0) ; "RTN","XQALSUR1",81,0) DATESURO(XQAUSER,XQALSTRT,XQALEND) ; returns surrogate(s) for XQAUSER in date range XQALSTRT to XQALEND, may be multiple values ^-separated "RTN","XQALSUR1",82,0) N XQALY,XQA0,XQALIEN,XQALS "RTN","XQALSUR1",83,0) S XQALY="" I XQALEND'>0 S XQALEND=4000101 "RTN","XQALSUR1",84,0) F XQALS=0:0 S XQALS=$O(^XTV(8992,XQAUSER,2,"B",XQALS)) Q:XQALS'>0 Q:XQALS'0 S XQA0=^XTV(8992,XQAUSER,2,XQALIEN,0) Q:$P(XQA0,U,3)'>XQALSTRT S XQALY=XQALY_$S(XQALY="":"",1:U)_$P(XQA0,U,2) "RTN","XQALSUR1",86,0) . Q "RTN","XQALSUR1",87,0) Q XQALY "RTN","XQALSUR1",88,0) ; "RTN","XQALSUR1",89,0) SURRO1(XQAUSER) ; "RTN","XQALSUR1",90,0) SURRO1G "RTN","XQALSUR1",91,0) N XQALSURO,XQALSTRT,XQALEND "RTN","XQALSUR1",92,0) D CHKREMV^XQALSURO "RTN","XQALSUR1",93,0) SURRO11 ; "RTN","XQALSUR1",94,0) S XQALSURO=$$NEWDLG() I XQALSURO'>0 Q "RTN","XQALSUR1",95,0) I $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0 W $C(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),! G SURRO1G "RTN","XQALSUR1",96,0) S XQALSTRT=+$$STRTDLG() I XQALSTRT<0 Q "RTN","XQALSUR1",97,0) S XQALEND=+$$ENDDLG() I XQALEND<0 Q "RTN","XQALSUR1",98,0) D SETSURO^XQALSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) "RTN","XQALSUR1",99,0) G SURRO11 ; "RTN","XQALSUR1",100,0) Q "RTN","XQALSUR1",101,0) ; "RTN","XQALSUR1",102,0) ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date "RTN","XQALSUR1",103,0) REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship "RTN","XQALSUR1",104,0) I $G(XQAUSER)'>0 Q "RTN","XQALSUR1",105,0) S XQALSURO=$G(XQALSURO),XQALSTRT=$G(XQALSTRT) "RTN","XQALSUR1",106,0) N XQALFM,XQALXREF,XQALSTR1,XQALSUR1,XQALNOW,XQALEND,XQA0 "RTN","XQALSUR1",107,0) ; ZEXCEPT: XQATEST (EXTERNAL VALUE - INDICATING TEST BEING RUN) "RTN","XQALSUR1",108,0) D CHEKSUBS^XQALSUR2(XQAUSER) "RTN","XQALSUR1",109,0) S XQALSUR1=+$P($G(^XTV(8992,XQAUSER,0)),U,2) S:XQALSURO'>0 XQALSURO=XQALSUR1 "RTN","XQALSUR1",110,0) S XQALSTR1=$P($G(^XTV(8992,XQAUSER,0)),U,3) S:XQALSTRT'>0 XQALSTRT=XQALSTR1 "RTN","XQALSUR1",111,0) S XQALEND=$P($G(^XTV(8992,XQAUSER,0)),U,4) "RTN","XQALSUR1",112,0) S XQALXREF=0 I XQALSTRT>0 F S XQALXREF=$O(^XTV(8992,XQAUSER,2,"B",XQALSTRT,XQALXREF)) Q:XQALXREF'>0 I $P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,2)=XQALSURO D "RTN","XQALSUR1",113,0) . S XQALEND=$P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,3) D DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) "RTN","XQALSUR1",114,0) . Q "RTN","XQALSUR1",115,0) S XQALSURO=$$CURRSURO^XQALSURO(XQAUSER) ; make sure current surrogate is updated if necessary. "RTN","XQALSUR1",116,0) Q "RTN","XQALSUR1",117,0) ; "RTN","XQALSUR1",118,0) DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) ; "RTN","XQALSUR1",119,0) N XQALNOW,XQALFM "RTN","XQALSUR1",120,0) ; ZEXCEPT: XQATEST (EXTERNAL VALUE - INDICATING TEST BEING RUN) "RTN","XQALSUR1",121,0) S XQAUSER=XQAUSER_",",XQALXREF=XQALXREF_","_XQAUSER "RTN","XQALSUR1",122,0) I XQALXREF>0 D "RTN","XQALSUR1",123,0) . S XQALNOW=$$NOW^XLFDT() "RTN","XQALSUR1",124,0) . I XQALSTRT>XQALNOW S XQALFM(8992.02,XQALXREF,.01)=XQALNOW ; if scheduled for later, mark start as now "RTN","XQALSUR1",125,0) . I (XQALEND>XQALNOW)!(XQALEND'>0) S XQALFM(8992.02,XQALXREF,.03)=XQALNOW ; update end time for surrogate to now "RTN","XQALSUR1",126,0) . I XQALSTRT'>XQALNOW S XQALFM(8992.02,XQALXREF,.04)=1 "RTN","XQALSUR1",127,0) . Q "RTN","XQALSUR1",128,0) I XQALSUR1=XQALSURO,XQALSTRT=XQALSTR1 D "RTN","XQALSUR1",129,0) . S XQALFM(8992,XQAUSER,.02)="@" "RTN","XQALSUR1",130,0) . S XQALFM(8992,XQAUSER,.03)="@" "RTN","XQALSUR1",131,0) . S XQALFM(8992,XQAUSER,.04)="@" "RTN","XQALSUR1",132,0) . Q "RTN","XQALSUR1",133,0) I $D(XQALFM) D FILE^DIE("","XQALFM") "RTN","XQALSUR1",134,0) I XQALSURO>0,'$D(XQATEST) D "RTN","XQALSUR1",135,0) . N XQAMESG,XMSUB,XMTEXT "RTN","XQALSUR1",136,0) . S XQAMESG(1,0)="You have been REMOVED as a surrogate recipient for alerts for" "RTN","XQALSUR1",137,0) . S XQAMESG(2,0)=$$GET1^DIQ(200,XQAUSER,.01,"E")_" (IEN="_$P(XQAUSER,",")_")." "RTN","XQALSUR1",138,0) . S XMTEXT="XQAMESG(",XMSUB="Removal as surrogate recipient" "RTN","XQALSUR1",139,0) . D SENDMESG^XQALSURO "RTN","XQALSUR1",140,0) . Q "RTN","XQALSUR1",141,0) Q "RTN","XQALSUR1",142,0) ; "RTN","XQALSUR1",143,0) NEWDLG() ; new surrogate dialog "RTN","XQALSUR1",144,0) N DIR,Y S DIR(0)="Y",DIR("A")="Do you want to SET a new surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate.",DIR("B")="NO" "RTN","XQALSUR1",145,0) S Y=$$ASKDIR(.DIR) I 'Y Q 0 "RTN","XQALSUR1",146,0) ; "RTN","XQALSUR1",147,0) S DIR(0)="P^200:AEMQ",DIR("A")="Select USER to be SURROGATE" S Y=$$ASKDIR(.DIR) ; COS-0401-41366 "RTN","XQALSUR1",148,0) I Y>0 W " ",$P(Y,U,2) "RTN","XQALSUR1",149,0) Q +Y "RTN","XQALSUR1",150,0) ; "RTN","XQALSUR1",151,0) STRTDLG() ; new surrogate start date/time dialog "RTN","XQALSUR1",152,0) N DIR "RTN","XQALSUR1",153,0) S DIR(0)="DO^::ATEX",DIR("A")="Specify Date/Time SURROGATE becomes active" ; BRX-1000-10427 "RTN","XQALSUR1",154,0) S DIR("A",1)="",DIR("A",2)="" "RTN","XQALSUR1",155,0) S DIR("A",3)="if no date/time is entered, alerts will start going to" "RTN","XQALSUR1",156,0) S DIR("A",4)="the SURROGATE immediately." "RTN","XQALSUR1",157,0) Q +$$ASKDIR(.DIR) "RTN","XQALSUR1",158,0) ; "RTN","XQALSUR1",159,0) ENDDLG() ; new surrogate end date/time dialog "RTN","XQALSUR1",160,0) N DIR "RTN","XQALSUR1",161,0) S DIR(0)="DO^::AETX",DIR("A")="Specify Date/Time SURROGATE should be removed" ; BRX-1000-10427 "RTN","XQALSUR1",162,0) S DIR("A",1)="",DIR("A",2)="" "RTN","XQALSUR1",163,0) S DIR("A",3)="if no date/time is entered, YOU must remove the SURROGATE" "RTN","XQALSUR1",164,0) S DIR("A",4)="to terminate alerts going to the SURROGATE" "RTN","XQALSUR1",165,0) Q +$$ASKDIR(.DIR) "RTN","XQALSUR1",166,0) ; "RTN","XQALSUR1",167,0) ASKDIR(DIR) ; "RTN","XQALSUR1",168,0) N Y,DTOUT,DUOUT "RTN","XQALSUR1",169,0) D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1 "RTN","XQALSUR1",170,0) Q Y "RTN","XTER1A") 0^7^B29100251 "RTN","XTER1A",1,0) XTER1A ;ISC-SF.SEA/JLI MSC/JDS- VA error reporting ;24APR2009 "RTN","XTER1A",2,0) ;;8.0;KERNEL;**63,112,120,MSC,IHS**;Jul 10, 1995 "RTN","XTER1A",3,0) ; "RTN","XTER1A",4,0) TWO ; "RTN","XTER1A",5,0) S XTNUM=2 "RTN","XTER1A",6,0) ONE ; "RTN","XTER1A",7,0) S:'$D(XTNUM) XTNUM=1 "RTN","XTER1A",8,0) S:'$D(XTNDATE) XTNDATE=$H-1 I '$D(ZTQUEUED) S XTNDAT1=$$HTFM^XLFDT(XTNDATE),XTNDAT2=XTNDAT1 G INT^XTER1A1 "RTN","XTER1A",9,0) K ^TMP($J,"XTER1A") D LISTN,LIST "RTN","XTER1A",10,0) EXIT K XTNUM,XTNDATE,XTERN,XTERX,X,N,N1,Y,C,XTOUT,Z,I,XTER1AX,XTER1AN,XTER1AN1,%XTZDAT,%XTZNUM,XTMES,XTDV1,XTMES,XTPRNT "RTN","XTER1A",11,0) Q "RTN","XTER1A",12,0) LISTN ; "RTN","XTER1A",13,0) F XTERN=0:0 S XTERN=$O(^%ZTER(1,XTNDATE,1,XTERN)) Q:XTERN'>0 I $D(^(XTERN,"ZE")) S XTERX=$E(^("ZE"),1,30),X=^("ZE") D "RTN","XTER1A",14,0) .S N1=0 F N=0:0 S N=$O(^TMP($J,"XTER1A",XTERX,N)) Q:N="" S N1=N I ^(N)=X Q "RTN","XTER1A",15,0) .I N="" S ^TMP($J,"XTER1A",XTERX,N1+1)=X,^(N1+1,"CNT")=1,^(1)=XTNDATE_U_XTERN "RTN","XTER1A",16,0) .E S ^("CNT")=^TMP($J,"XTER1A",XTERX,N,"CNT")+1 I ^("CNT")'>XTNUM S Y=^("CNT"),^(Y)=XTNDATE_U_XTERN "RTN","XTER1A",17,0) .Q "RTN","XTER1A",18,0) Q "RTN","XTER1A",19,0) LIST ; "RTN","XTER1A",20,0) S XTERX="",C=0,XTOUT=0 K ^TMP($J,"XTER") "RTN","XTER1A",21,0) F S XTERX=$O(^TMP($J,"XTER1A",XTERX)) Q:XTERX="" F N=0:0 S N=$O(^TMP($J,"XTER1A",XTERX,N)) Q:N'>0 D "RTN","XTER1A",22,0) .S X=^TMP($J,"XTER1A",XTERX,N) S C=C+1,^TMP($J,"XTER",C)="",C=C+1,^(C)="",Z=$J(^TMP($J,"XTER1A",XTERX,N,"CNT"),8)_" " "RTN","XTER1A",23,0) .F I=1:60 S Y=$E(X,I,I+59) Q:Y="" S C=C+1,^TMP($J,"XTER",C)=Z_Y,Z=" " "RTN","XTER1A",24,0) S XTER1AX="" F S XTER1AX=$O(^TMP($J,"XTER1A",XTER1AX)) Q:XTER1AX="" F XTER1AN=0:0 S XTER1AN=$O(^TMP($J,"XTER1A",XTER1AX,XTER1AN)) Q:XTER1AN'>0 D "RTN","XTER1A",25,0) .F XTER1AN1=0:0 S XTER1AN1=$O(^TMP($J,"XTER1A",XTER1AX,XTER1AN,XTER1AN1)) Q:XTER1AN1'>0 S X=^(XTER1AN1) D "RTN","XTER1A",26,0) ..S C=C+1,^TMP($J,"XTER",C)="|PAGE|" S %XTZDAT=+X,%XTZNUM=$P(X,U,2),XTDV1=0 S XTMES=1 D WRT^XTER1 "RTN","XTER1A",27,0) D:IO=""&$D(^TMP($J,"XTER")) MESSG D:IO'="" WRITER "RTN","XTER1A",28,0) K ^TMP($J,"XTER") S C=0 I IO'="" U IO D ^%ZISC "RTN","XTER1A",29,0) Q "RTN","XTER1A",30,0) ; "RTN","XTER1A",31,0) MESG N DWPK,DWLW,DIC K ^TMP($J,"XTER"),^TMP($J,"XTER1") "RTN","XTER1A",32,0) W @IOF,!!,"Enter any comments to precede the error listing:" "RTN","XTER1A",33,0) S DWPK=1,DWLW=75,DIC="^TMP($J,""XTER1""," D EN^DIWE "RTN","XTER1A",34,0) S C=0 W ! F I=0:0 S I=$O(^TMP($J,"XTER1",I)) Q:I'>0 S C=I,^TMP($J,"XTER",I)=^TMP($J,"XTER1",I,0) "RTN","XTER1A",35,0) S XTMES=1,XTDV1=0 D WRT^XTER1 D:C>0 MESSG "RTN","XTER1A",36,0) S C=0 K XTMES,^TMP($J,"XTER"),^TMP($J,"XTER1") "RTN","XTER1A",37,0) G XTERR^XTER "RTN","XTER1A",38,0) ; "RTN","XTER1A",39,0) PRNT K ^TMP($J,"XTER"),ZTIO "RTN","XTER1A",40,0) S C=0,%ZIS="MQ" D ^%ZIS I POP D HOME^%ZIS G WRT^XTER1 "RTN","XTER1A",41,0) I $D(IO("Q")) D S XTX="" G XTERR^XTER "RTN","XTER1A",42,0) . K IO("Q") S ZTRTN="DQPRNT^XTER1A",ZTSAVE("%XTZDAT")="",ZTSAVE("%XTZNUM")="",ZTDESC="XTER1A-PRINT OF ERROR" D ^%ZTLOAD K ZTSK D HOME^%ZIS "RTN","XTER1A",43,0) ; "RTN","XTER1A",44,0) DQPRNT S XTPRNT=1,XTOUT=0 D WRT^XTER1 U IO D:C>0 WRITER "RTN","XTER1A",45,0) K ^TMP($J,"XTER"),XTX,XTPRNT S C=0 D ^%ZISC I $D(ZTQUEUED) Q "RTN","XTER1A",46,0) G XTERR^XTER "RTN","XTER1A",47,0) ; "RTN","XTER1A",48,0) WRITER F %=0:0 S %=$O(^TMP($J,"XTER",%)) Q:%'>0 W:((IOSL-$Y)'>4&$G(XTPRNT)) @IOF S %1=$S($D(^(%))=1:^(%),1:^(%,0)) D "RTN","XTER1A",49,0) .I $E(%1,1,6)="|PAGE|" W @IOF S %1=$E(%1,7,$L(%1)) Q:%1="" "RTN","XTER1A",50,0) .I $E(%1,1,4)="@IOF" W @IOF S %1=$E(%1,5,$L(%1)) Q:%1="" "RTN","XTER1A",51,0) .W !,%1 "RTN","XTER1A",52,0) K %,%1 "RTN","XTER1A",53,0) Q "RTN","XTER1A",54,0) MESSG S XMY(DUZ)="",XMDUZ=.5 I '$D(ZTQUEUED) K XMY,XMDUZ "RTN","XTER1A",55,0) S XMTEXT="^TMP($J,""XTER"",",XMSUB="ERROR - "_$E(%XTZE,1,40) F Q:XMSUB'[U S XMSUB=$P(XMSUB,U)_"~U~"_$P(XMSUB,U,2,99) "RTN","XTER1A",56,0) D ^XMD K XMY,XMTEXT,XMSUB "RTN","XTER1A",57,0) Q "RTN","XTER1A",58,0) ; "RTN","XTER1A",59,0) MORE Q:$G(XTMES) N DIR,DTOUT,DIRUT,DUOUT "RTN","XTER1A",60,0) S XTOUT=0,XTX="" D WRITER K ^TMP($J,"XTER") S C=0 "RTN","XTER1A",61,0) I '$D(ZTQUEUED),'$G(XTPRNT),$G(IOST)["C-" D "RTN","XTER1A",62,0) . S:($D(X)#2) XTMORE=X S DIR(0)="FO^0:50",DIR("A")=" Enter '^' to quit listing, to continue..." "RTN","XTER1A",63,0) . D ^DIR K DIR S:$D(DTOUT) X="^" S XTX=X S:$D(XTMORE) X=XTMORE K XTMORE "RTN","XTER1A",64,0) I $D(XTX),$E(XTX)="^" S XTOUT=1 Q "RTN","XTER1A",65,0) I $G(XTPRNT) W @IOF "RTN","XTER1A",66,0) Q "RTN","XTER1A",67,0) ; "RTN","XTER1A",68,0) LST S X=" ",XTQ="" N XTXT,XBLNK S $P(XBLNK," ",80)=" " "RTN","XTER1A",69,0) T1 S X=$O(^%ZTER(1,%XTZDAT,1,X),-1) R XTQ:0 Q:XTQ'="" G T2:X'>0,T1:'($D(^(X,"ZE"))#2) S XTP=^("ZE"),XTS="" "RTN","XTER1A",70,0) F S XTS=$O(^TMP($J,"XTERSCR",XTS)) Q:XTS="" I XTP[XTS,XTD S XTD=XTD+1 G T1 "RTN","XTER1A",71,0) ; "RTN","XTER1A",72,0) I '(X#20) S %XTERRX=X D MORE Q:XTOUT Q:XTX>0 D T3 S X=%XTERRX "RTN","XTER1A",73,0) I ^%ZTER(1,%XTZDAT,1,X,"ZE")["," S %XTERR=$P($P(^("ZE"),",",4),"-",4),%XTERR=$P($P(^("ZE"),",",2),"-",3)_$S(%XTERR="":"",1:"(")_%XTERR_$S(%XTERR="":"",1:")") S XTXT=$J(X,3)_") "_"<"_%XTERR_">"_$P(^("ZE"),",",1)_" " "RTN","XTER1A",74,0) I ^%ZTER(1,%XTZDAT,1,X,"ZE")'["," S XTXT=$J(X,3)_") "_^("ZE") "RTN","XTER1A",75,0) S %XTZNUM=X,%="" I $D(^%ZTER(1,%XTZDAT,1,%XTZNUM,"H")) S %H=^("H") D YMD^%DTC S %=$P(%,".",2)_"000000",%=$E(%,1,2)_":"_$E(%,3,4)_":"_$E(%,5,6) "RTN","XTER1A",76,0) S X=%XTZNUM S XTXT=$S($L(XTXT)>34:XTXT,1:$E(XTXT_XBLNK,1,34))_% "RTN","XTER1A",77,0) I $D(^%ZTER(1,%XTZDAT,1,X,"J")) S XTXT=XTXT_" ["_$P($P(^("J"),U,4),",")_"]" ;_" "_$J($P(^("J"),U,5),7) "RTN","XTER1A",78,0) D IHSXQY0 ;***IHS "RTN","XTER1A",79,0) W !,$E(XTXT,1,79) "RTN","XTER1A",80,0) COMMENT I $D(^DD(3.0751,21400)) D ;**MSC/GFT "RTN","XTER1A",81,0) .N DIC,DIQ,DR,DA,Y,S,DK,D0,D1 "RTN","XTER1A",82,0) .S DIC="^%ZTER(1,"_%XTZDAT_",1,",DIQ(0)="A",DR=21400,DA=X,DA(1)=%XTZDAT "RTN","XTER1A",83,0) .I $D(@(DIC_DA_",21400)")) N X D EN^DIQ "RTN","XTER1A",84,0) G T1 "RTN","XTER1A",85,0) T2 I XTD W !! I XTD-1 W XTD-1," screened error",$S(XTD-1>1:"s",1:""),! "RTN","XTER1A",86,0) ;D MORE "RTN","XTER1A",87,0) Q "RTN","XTER1A",88,0) T3 W !!,?11,"$ZE",?41,"Time",?49,"UCI,VOL",?61,"$J",?69,"$I",! "RTN","XTER1A",89,0) Q "RTN","XTER1A",90,0) INTRACT ; "RTN","XTER1A",91,0) G INTRACT^XTER1A1 "RTN","XTER1A",92,0) ; "RTN","XTER1A",93,0) ; "RTN","XTER1A",94,0) ; "RTN","XTER1A",95,0) ; "RTN","XTER1A",96,0) IHSXQY0 ;IHS/ANMC/LJF 5/20/99 find option name "RTN","XTER1A",97,0) NEW IHS,FOUND,STR "RTN","XTER1A",98,0) S (FOUND,IHS)=0,STR="" "RTN","XTER1A",99,0) F S IHS=$O(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS)) Q:'IHS Q:FOUND D "RTN","XTER1A",100,0) .I $G(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS,0))="DUZ" D Q "RTN","XTER1A",101,0) ..N D,Y S D=$G(^("D")) I D S Y=$P($G(^%ZTER(1,%XTZDAT,1,X,"J")),U,4),Y=$$UCICHECK^%ZOSV(Y) I $L(Y)>2 S Y=$$NAMESP(Y),STR=$P($G(^[Y]VA(200,D,0)),",")_": " "RTN","XTER1A",102,0) . Q:$G(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS,0))'="XQY0" "RTN","XTER1A",103,0) . S STR=STR_$P($G(^%ZTER(1,%XTZDAT,1,X,"ZV",IHS,"D")),U) "RTN","XTER1A",104,0) . S STR=$E(STR,1,26)_$$REPEAT^XLFSTR(" ",(26-$L(STR))),FOUND=1 "RTN","XTER1A",105,0) S XTXT=XTXT_" "_$G(STR) "RTN","XTER1A",106,0) Q "RTN","XTER1A",107,0) NAMESP(Y) ; "RTN","XTER1A",108,0) I ^%ZOSF("OS")'["GT.M" Q Y "RTN","XTER1A",109,0) Q $ZGB "RTN","XUMF5AU") 0^43^B76801793 "RTN","XUMF5AU",1,0) XUMF5AU ;ISS/PAVEL,MSC/JDA - XUMF5 MD5 Hash API ;27APR2009 "RTN","XUMF5AU",2,0) ;;8.0;KERNEL;**383,MSC**;July 10, 1995 "RTN","XUMF5AU",3,0) ; "RTN","XUMF5AU",4,0) ;MD5 based on info from 4.005 SORT BY VUID;;original name was 'VESOUHSH' ; Secure hash functions "RTN","XUMF5AU",5,0) ;;(c) Copyright 1994 - 2004, ESI Technology Corp, Natick MA "RTN","XUMF5AU",6,0) ;; This source code contains the intellectual property of its copyright holder(s), "RTN","XUMF5AU",7,0) ;; and is made available under a license. If you are not familiar with the terms "RTN","XUMF5AU",8,0) ;; of the license, please refer to the license.txt file that is a part of the "RTN","XUMF5AU",9,0) ;; distribution kit. "RTN","XUMF5AU",10,0) ;; This is a routine version where Variables and Commands set to be Upercase. Pavel "RTN","XUMF5AU",11,0) ; "RTN","XUMF5AU",12,0) Q "RTN","XUMF5AU",13,0) ;;************************************************** "RTN","XUMF5AU",14,0) ;;MD5 'R'egular portion of the code. This will handle "RTN","XUMF5AU",15,0) ;; one string at a time. "RTN","XUMF5AU",16,0) ;;************************************************** "RTN","XUMF5AU",17,0) MD5R(STR) ; Construct a 128-bit MD5 hash of the input. "RTN","XUMF5AU",18,0) N TWOTO "RTN","XUMF5AU",19,0) N A,B,C,D "RTN","XUMF5AU",20,0) N AA,BB,CC,DD "RTN","XUMF5AU",21,0) D INITR "RTN","XUMF5AU",22,0) PAD1R ; Pad str out to 56 bytes mod 64 "RTN","XUMF5AU",23,0) ; Padding is a 1 bit followed by all zero bits "RTN","XUMF5AU",24,0) N LEN,MOD,NPAD,PAD "RTN","XUMF5AU",25,0) S LEN=$L(STR),MOD=LEN#64 "RTN","XUMF5AU",26,0) S NPAD=$S(MOD<56:56-MOD,1:120-MOD) "RTN","XUMF5AU",27,0) S PAD=$C(128) "RTN","XUMF5AU",28,0) S:NPAD>1 $P(PAD,$C(0),NPAD)="" "RTN","XUMF5AU",29,0) S STR=STR_PAD "RTN","XUMF5AU",30,0) PAD2R ; Append length in bits as 64-bit integer, little endian "RTN","XUMF5AU",31,0) S LEN=LEN*8 "RTN","XUMF5AU",32,0) S STR=STR_$$UI64BIT(LEN) "RTN","XUMF5AU",33,0) PROCESSR ; Main processing and transformation loop "RTN","XUMF5AU",34,0) N J,POS,N,I "RTN","XUMF5AU",35,0) N X ; X(J) is a 4-byte word from a 64-byte block "RTN","XUMF5AU",36,0) S N=$L(STR)/64 ; Number of 64-byte blocks "RTN","XUMF5AU",37,0) F I=0:1:N-1 D "RTN","XUMF5AU",38,0) . F J=0:1:15 S POS=(64*I)+(4*J),X(J)=$E(STR,POS+1,POS+4) "RTN","XUMF5AU",39,0) . D SAVE "RTN","XUMF5AU",40,0) . D ROUND1 "RTN","XUMF5AU",41,0) . D ROUND2 "RTN","XUMF5AU",42,0) . D ROUND3 "RTN","XUMF5AU",43,0) . D ROUND4 "RTN","XUMF5AU",44,0) . D INCR "RTN","XUMF5AU",45,0) K X "RTN","XUMF5AU",46,0) Q A_B_C_D "RTN","XUMF5AU",47,0) ; "RTN","XUMF5AU",48,0) INITR ; Initialization "RTN","XUMF5AU",49,0) ; Set up array of powers of two for rotation "RTN","XUMF5AU",50,0) N I,N "RTN","XUMF5AU",51,0) S N=1 "RTN","XUMF5AU",52,0) F I=0:1:31 S TWOTO(I)=N,N=N+N "RTN","XUMF5AU",53,0) ; Initialize 4-byte buffers A,B,C,D "RTN","XUMF5AU",54,0) S A=$C(1,35,69,103) "RTN","XUMF5AU",55,0) S B=$C(137,171,205,239) "RTN","XUMF5AU",56,0) S C=$C(254,220,186,152) "RTN","XUMF5AU",57,0) S D=$C(118,84,50,16) "RTN","XUMF5AU",58,0) Q "RTN","XUMF5AU",59,0) ; "RTN","XUMF5AU",60,0) ;;************************************************** "RTN","XUMF5AU",61,0) ;;MD5 'E'nhanced portion of the code. This will handle "RTN","XUMF5AU",62,0) ;; multiple strings and produce a value for them all "RTN","XUMF5AU",63,0) ;; as if they were submitted as one long string. "RTN","XUMF5AU",64,0) ;;************************************************** "RTN","XUMF5AU",65,0) MD5E(ABCD,STR,PP,LL) ; Construct a 128-bit MD5 hash of the input. "RTN","XUMF5AU",66,0) N TWOTO "RTN","XUMF5AU",67,0) N A,B,C,D "RTN","XUMF5AU",68,0) N AA,BB,CC,DD "RTN","XUMF5AU",69,0) D INITE(ABCD) "RTN","XUMF5AU",70,0) PAD1E ; Pad str out to 56 bytes mod 64 "RTN","XUMF5AU",71,0) ; Padding is a 1 bit followed by all zero bits "RTN","XUMF5AU",72,0) ; PP = 1 Don't pad with $C(128) !!! Pavel Set to 1 if this is not last string !! "RTN","XUMF5AU",73,0) ; Set to 0 if this is last string !! "RTN","XUMF5AU",74,0) ; LL = Lenght passed form outside for pading of little endian Pavel !!! - "RTN","XUMF5AU",75,0) ; Seting lenght if this is last value othervise computed lenght used... "RTN","XUMF5AU",76,0) N LEN,MOD,NPAD,PAD "RTN","XUMF5AU",77,0) S LEN=$L(STR),MOD=LEN#64 "RTN","XUMF5AU",78,0) S:$G(LL) LEN=LL ;Pavel "RTN","XUMF5AU",79,0) S NPAD=$S(MOD<56:56-MOD,1:120-MOD) "RTN","XUMF5AU",80,0) S PAD=$C(128) "RTN","XUMF5AU",81,0) S:NPAD>1 $P(PAD,$C(0),NPAD)="" "RTN","XUMF5AU",82,0) S:'$G(PP) STR=STR_PAD ;Pavel "RTN","XUMF5AU",83,0) ;S STR=STR_PAD "RTN","XUMF5AU",84,0) PAD2E ; Append length in bits as 64-bit integer, little endian "RTN","XUMF5AU",85,0) S LEN=LEN*8 "RTN","XUMF5AU",86,0) S STR=STR_$$UI64BIT(LEN) "RTN","XUMF5AU",87,0) PROCESSE ; Main processing and transformation loop "RTN","XUMF5AU",88,0) N J,POS,N,I "RTN","XUMF5AU",89,0) N X ; X(J) is a 4-byte word from a 64-byte block "RTN","XUMF5AU",90,0) ;S N=$L(STR)/64 ; Number of 64-byte blocks "RTN","XUMF5AU",91,0) S N=$L(STR)\64 ; Number of 64-byte blocks "RTN","XUMF5AU",92,0) F I=0:1:N-1 D "RTN","XUMF5AU",93,0) . F J=0:1:15 S POS=(64*I)+(4*J),X(J)=$E(STR,POS+1,POS+4) "RTN","XUMF5AU",94,0) . D SAVE "RTN","XUMF5AU",95,0) . D ROUND1 "RTN","XUMF5AU",96,0) . D ROUND2 "RTN","XUMF5AU",97,0) . D ROUND3 "RTN","XUMF5AU",98,0) . D ROUND4 "RTN","XUMF5AU",99,0) . D INCR "RTN","XUMF5AU",100,0) . ;W !,I," ABCD=",$$MAIN^XUMF5BYT($$HEX(A_B_C_D)),! "RTN","XUMF5AU",101,0) K X "RTN","XUMF5AU",102,0) Q A_B_C_D "RTN","XUMF5AU",103,0) ; "RTN","XUMF5AU",104,0) INITE(LASTABCD) ; Initialization "RTN","XUMF5AU",105,0) ; Set up array of powers of two for rotation "RTN","XUMF5AU",106,0) N I,N,L "RTN","XUMF5AU",107,0) S N=1 "RTN","XUMF5AU",108,0) F I=0:1:31 S TWOTO(I)=N,N=N+N "RTN","XUMF5AU",109,0) ; Initialize 4-byte buffers A,B,C,D "RTN","XUMF5AU",110,0) S A=$E(LASTABCD,1,4) "RTN","XUMF5AU",111,0) S B=$E(LASTABCD,5,8) "RTN","XUMF5AU",112,0) S C=$E(LASTABCD,9,12) "RTN","XUMF5AU",113,0) S D=$E(LASTABCD,13,16) "RTN","XUMF5AU",114,0) Q "RTN","XUMF5AU",115,0) ; "RTN","XUMF5AU",116,0) ;;************************************************** "RTN","XUMF5AU",117,0) ;;This is where common code starts, used by both "RTN","XUMF5AU",118,0) ;; Regular and Enhanced portions of this routine. "RTN","XUMF5AU",119,0) ;;************************************************** "RTN","XUMF5AU",120,0) SAVE ; Save buffers "RTN","XUMF5AU",121,0) S AA=A,BB=B,CC=C,DD=D "RTN","XUMF5AU",122,0) Q "RTN","XUMF5AU",123,0) ; "RTN","XUMF5AU",124,0) ROUND1 ; First round of transformation "RTN","XUMF5AU",125,0) D SUB(.A,B,C,D,X(0),7,3614090360,1) "RTN","XUMF5AU",126,0) D SUB(.D,A,B,C,X(1),12,3905402710,1) "RTN","XUMF5AU",127,0) D SUB(.C,D,A,B,X(2),17,606105819,1) "RTN","XUMF5AU",128,0) D SUB(.B,C,D,A,X(3),22,3250441966,1) "RTN","XUMF5AU",129,0) D SUB(.A,B,C,D,X(4),7,4118548399,1) "RTN","XUMF5AU",130,0) D SUB(.D,A,B,C,X(5),12,1200080426,1) "RTN","XUMF5AU",131,0) D SUB(.C,D,A,B,X(6),17,2821735955,1) "RTN","XUMF5AU",132,0) D SUB(.B,C,D,A,X(7),22,4249261313,1) "RTN","XUMF5AU",133,0) D SUB(.A,B,C,D,X(8),7,1770035416,1) "RTN","XUMF5AU",134,0) D SUB(.D,A,B,C,X(9),12,2336552879,1) "RTN","XUMF5AU",135,0) D SUB(.C,D,A,B,X(10),17,4294925233,1) "RTN","XUMF5AU",136,0) D SUB(.B,C,D,A,X(11),22,2304563134,1) "RTN","XUMF5AU",137,0) D SUB(.A,B,C,D,X(12),7,1804603682,1) "RTN","XUMF5AU",138,0) D SUB(.D,A,B,C,X(13),12,4254626195,1) "RTN","XUMF5AU",139,0) D SUB(.C,D,A,B,X(14),17,2792965006,1) "RTN","XUMF5AU",140,0) D SUB(.B,C,D,A,X(15),22,1236535329,1) "RTN","XUMF5AU",141,0) Q "RTN","XUMF5AU",142,0) ; "RTN","XUMF5AU",143,0) ROUND2 ; Second round of transformation "RTN","XUMF5AU",144,0) D SUB(.A,B,C,D,X(1),5,4129170786,2) "RTN","XUMF5AU",145,0) D SUB(.D,A,B,C,X(6),9,3225465664,2) "RTN","XUMF5AU",146,0) D SUB(.C,D,A,B,X(11),14,643717713,2) "RTN","XUMF5AU",147,0) D SUB(.B,C,D,A,X(0),20,3921069994,2) "RTN","XUMF5AU",148,0) D SUB(.A,B,C,D,X(5),5,3593408605,2) "RTN","XUMF5AU",149,0) D SUB(.D,A,B,C,X(10),9,38016083,2) "RTN","XUMF5AU",150,0) D SUB(.C,D,A,B,X(15),14,3634488961,2) "RTN","XUMF5AU",151,0) D SUB(.B,C,D,A,X(4),20,3889429448,2) "RTN","XUMF5AU",152,0) D SUB(.A,B,C,D,X(9),5,568446438,2) "RTN","XUMF5AU",153,0) D SUB(.D,A,B,C,X(14),9,3275163606,2) "RTN","XUMF5AU",154,0) D SUB(.C,D,A,B,X(3),14,4107603335,2) "RTN","XUMF5AU",155,0) D SUB(.B,C,D,A,X(8),20,1163531501,2) "RTN","XUMF5AU",156,0) D SUB(.A,B,C,D,X(13),5,2850285829,2) "RTN","XUMF5AU",157,0) D SUB(.D,A,B,C,X(2),9,4243563512,2) "RTN","XUMF5AU",158,0) D SUB(.C,D,A,B,X(7),14,1735328473,2) "RTN","XUMF5AU",159,0) D SUB(.B,C,D,A,X(12),20,2368359562,2) "RTN","XUMF5AU",160,0) Q "RTN","XUMF5AU",161,0) ; "RTN","XUMF5AU",162,0) ROUND3 ; Third round of transformation "RTN","XUMF5AU",163,0) D SUB(.A,B,C,D,X(5),4,4294588738,3) "RTN","XUMF5AU",164,0) D SUB(.D,A,B,C,X(8),11,2272392833,3) "RTN","XUMF5AU",165,0) D SUB(.C,D,A,B,X(11),16,1839030562,3) "RTN","XUMF5AU",166,0) D SUB(.B,C,D,A,X(14),23,4259657740,3) "RTN","XUMF5AU",167,0) D SUB(.A,B,C,D,X(1),4,2763975236,3) "RTN","XUMF5AU",168,0) D SUB(.D,A,B,C,X(4),11,1272893353,3) "RTN","XUMF5AU",169,0) D SUB(.C,D,A,B,X(7),16,4139469664,3) "RTN","XUMF5AU",170,0) D SUB(.B,C,D,A,X(10),23,3200236656,3) "RTN","XUMF5AU",171,0) D SUB(.A,B,C,D,X(13),4,681279174,3) "RTN","XUMF5AU",172,0) D SUB(.D,A,B,C,X(0),11,3936430074,3) "RTN","XUMF5AU",173,0) D SUB(.C,D,A,B,X(3),16,3572445317,3) "RTN","XUMF5AU",174,0) D SUB(.B,C,D,A,X(6),23,76029189,3) "RTN","XUMF5AU",175,0) D SUB(.A,B,C,D,X(9),4,3654602809,3) "RTN","XUMF5AU",176,0) D SUB(.D,A,B,C,X(12),11,3873151461,3) "RTN","XUMF5AU",177,0) D SUB(.C,D,A,B,X(15),16,530742520,3) "RTN","XUMF5AU",178,0) D SUB(.B,C,D,A,X(2),23,3299628645,3) "RTN","XUMF5AU",179,0) Q "RTN","XUMF5AU",180,0) ; "RTN","XUMF5AU",181,0) ROUND4 ; Fourth round of transformation "RTN","XUMF5AU",182,0) D SUB(.A,B,C,D,X(0),6,4096336452,4) "RTN","XUMF5AU",183,0) D SUB(.D,A,B,C,X(7),10,1126891415,4) "RTN","XUMF5AU",184,0) D SUB(.C,D,A,B,X(14),15,2878612391,4) "RTN","XUMF5AU",185,0) D SUB(.B,C,D,A,X(5),21,4237533241,4) "RTN","XUMF5AU",186,0) D SUB(.A,B,C,D,X(12),6,1700485571,4) "RTN","XUMF5AU",187,0) D SUB(.D,A,B,C,X(3),10,2399980690,4) "RTN","XUMF5AU",188,0) D SUB(.C,D,A,B,X(10),15,4293915773,4) "RTN","XUMF5AU",189,0) D SUB(.B,C,D,A,X(1),21,2240044497,4) "RTN","XUMF5AU",190,0) D SUB(.A,B,C,D,X(8),6,1873313359,4) "RTN","XUMF5AU",191,0) D SUB(.D,A,B,C,X(15),10,4264355552,4) "RTN","XUMF5AU",192,0) D SUB(.C,D,A,B,X(6),15,2734768916,4) "RTN","XUMF5AU",193,0) D SUB(.B,C,D,A,X(13),21,1309151649,4) "RTN","XUMF5AU",194,0) D SUB(.A,B,C,D,X(4),6,4149444226,4) "RTN","XUMF5AU",195,0) D SUB(.D,A,B,C,X(11),10,3174756917,4) "RTN","XUMF5AU",196,0) D SUB(.C,D,A,B,X(2),15,718787259,4) "RTN","XUMF5AU",197,0) D SUB(.B,C,D,A,X(9),21,3951481745,4) "RTN","XUMF5AU",198,0) Q "RTN","XUMF5AU",199,0) INCR ; "RTN","XUMF5AU",200,0) S A=$$ADD(A,AA) "RTN","XUMF5AU",201,0) S B=$$ADD(B,BB) "RTN","XUMF5AU",202,0) S C=$$ADD(C,CC) "RTN","XUMF5AU",203,0) S D=$$ADD(D,DD) "RTN","XUMF5AU",204,0) Q "RTN","XUMF5AU",205,0) ; "RTN","XUMF5AU",206,0) ; Auxiliary functions "RTN","XUMF5AU",207,0) ; "RTN","XUMF5AU",208,0) SUB(A,B,C,D,X,S,AC,FN) ; FN is 1 (F), 2 (G), 3 (H) or 4 (I) "RTN","XUMF5AU",209,0) N INT,COMB,CMD,DO "RTN","XUMF5AU",210,0) S INT=$$UINT32(A) "RTN","XUMF5AU",211,0) S DO="COMB"_FN "RTN","XUMF5AU",212,0) D @DO "RTN","XUMF5AU",213,0) S INT=$$ADDIW(INT,COMB) "RTN","XUMF5AU",214,0) S INT=$$ADDIW(INT,X) "RTN","XUMF5AU",215,0) S INT=$$ADDII(INT,AC) "RTN","XUMF5AU",216,0) S INT=$$ROTLI(INT,S) "RTN","XUMF5AU",217,0) S INT=$$ADDIW(INT,B) "RTN","XUMF5AU",218,0) S A=$$UI32BIT(INT) "RTN","XUMF5AU",219,0) Q "RTN","XUMF5AU",220,0) COMB ; Choose F, G, H or I "RTN","XUMF5AU",221,0) COMB1 S COMB=$$OR($$AND(B,C),$$AND($$NOT(B),D)) Q ; F "RTN","XUMF5AU",222,0) COMB2 S COMB=$$OR($$AND(B,D),$$AND(C,$$NOT(D))) Q ; G "RTN","XUMF5AU",223,0) COMB3 S COMB=$$XOR($$XOR(B,C),D) Q ; H "RTN","XUMF5AU",224,0) COMB4 S COMB=$$XOR(C,$$OR(B,$$NOT(D))) Q ; I "RTN","XUMF5AU",225,0) Q "RTN","XUMF5AU",226,0) ; "RTN","XUMF5AU",227,0) ; Boolean functions assume args are 4-character strings "RTN","XUMF5AU",228,0) ; "RTN","XUMF5AU",229,0) AND(X,Y) ; "RTN","XUMF5AU",230,0) I ^%ZOSF("OS")["GT.M" Q $ZBITAND(X,Y) "RTN","XUMF5AU",231,0) Q $ZBOOLEAN(X,Y,1) ;;EOCONDCD;CACHE "RTN","XUMF5AU",232,0) Q X ; Placeholder for other M implementations "RTN","XUMF5AU",233,0) ; "RTN","XUMF5AU",234,0) OR(X,Y) ; "RTN","XUMF5AU",235,0) I ^%ZOSF("OS")["GT.M" Q $ZBITOR(X,Y) "RTN","XUMF5AU",236,0) Q $ZBOOLEAN(X,Y,7) ;;EOCONDCD;CACHE "RTN","XUMF5AU",237,0) Q X ; Placeholder for other M implementations "RTN","XUMF5AU",238,0) ; "RTN","XUMF5AU",239,0) XOR(X,Y) ; "RTN","XUMF5AU",240,0) I ^%ZOSF("OS")["GT.M" Q $ZBITXOR(X,Y) "RTN","XUMF5AU",241,0) Q $ZBOOLEAN(X,Y,6) ;;EOCONDCD;CACHE "RTN","XUMF5AU",242,0) Q X ; Placeholder for other M implementations "RTN","XUMF5AU",243,0) ; "RTN","XUMF5AU",244,0) NOT(X) ; "RTN","XUMF5AU",245,0) I ^%ZOSF("OS")["GT.M" Q $ZBITNOT(X) "RTN","XUMF5AU",246,0) Q $ZBOOLEAN(X,X,12) ;;EOCONDCD;CACHE "RTN","XUMF5AU",247,0) Q X ; Placeholder for other M implementations "RTN","XUMF5AU",248,0) ; "RTN","XUMF5AU",249,0) ; Functions to add and rotate 32-bit words "RTN","XUMF5AU",250,0) ; X and Y are 4-character strings "RTN","XUMF5AU",251,0) ; m, n and s are integers "RTN","XUMF5AU",252,0) ; ADD and ROTL return 4-character strings "RTN","XUMF5AU",253,0) ; ADDIW, ADDII and ROTLI return integers "RTN","XUMF5AU",254,0) ; "RTN","XUMF5AU",255,0) ADD(X,Y) ; modulo 2**32 "RTN","XUMF5AU",256,0) Q $$UI32BIT($$UINT32(X)+$$UINT32(Y)#4294967296) "RTN","XUMF5AU",257,0) ; "RTN","XUMF5AU",258,0) ADDIW(M,Y) ; modulo 2**32 "RTN","XUMF5AU",259,0) Q M+$$UINT32(Y)#4294967296 "RTN","XUMF5AU",260,0) ; "RTN","XUMF5AU",261,0) ADDII(M,N) ; modulo 2**32 "RTN","XUMF5AU",262,0) Q M+N#4294967296 "RTN","XUMF5AU",263,0) ; "RTN","XUMF5AU",264,0) ROTL(X,S) ; rotate left by s bits "RTN","XUMF5AU",265,0) N INT,RIGHT,SWAP "RTN","XUMF5AU",266,0) S INT=$$UINT32(X) "RTN","XUMF5AU",267,0) S RIGHT=INT#TWOTO(32-S) "RTN","XUMF5AU",268,0) S SWAP=RIGHT*TWOTO(S)+(INT\TWOTO(32-S)) "RTN","XUMF5AU",269,0) Q $$UI32BIT(SWAP) "RTN","XUMF5AU",270,0) ; "RTN","XUMF5AU",271,0) ROTLI(N,S) ; rotate left by s bits "RTN","XUMF5AU",272,0) N RIGHT,SWAP "RTN","XUMF5AU",273,0) S RIGHT=N#TWOTO(32-S) "RTN","XUMF5AU",274,0) S SWAP=RIGHT*TWOTO(S)+(N\TWOTO(32-S)) "RTN","XUMF5AU",275,0) Q SWAP "RTN","XUMF5AU",276,0) ; "RTN","XUMF5AU",277,0) ; Utility functions "RTN","XUMF5AU",278,0) ; "RTN","XUMF5AU",279,0) UI64BIT(N) ; Convert unsigned integer to 64-bit form, little endian "RTN","XUMF5AU",280,0) ; code from CORBA ULONGLONG marshaling "RTN","XUMF5AU",281,0) N D,X,I "RTN","XUMF5AU",282,0) S D="" "RTN","XUMF5AU",283,0) F I=7:-1:1 D "RTN","XUMF5AU",284,0) . S X=0 "RTN","XUMF5AU",285,0) . F Q:(N<(256**I)) S X=X+1,N=N-(256**I) "RTN","XUMF5AU",286,0) . S X(I)=X "RTN","XUMF5AU",287,0) S D=D_$C(N) "RTN","XUMF5AU",288,0) F I=1:1:7 S D=D_$C(X(I)) "RTN","XUMF5AU",289,0) Q D "RTN","XUMF5AU",290,0) ; "RTN","XUMF5AU",291,0) UI32BIT(N) ; Convert unsigned integer to 32-bit form, little endian "RTN","XUMF5AU",292,0) ; code from CORBA ULONG marshaling "RTN","XUMF5AU",293,0) Q $C(N#256,(N\256#256),(N\(65536)#256),(N\(16777216)#256)) "RTN","XUMF5AU",294,0) ; "RTN","XUMF5AU",295,0) UINT32(STR) ; Get integer value from bits of 4-character string "RTN","XUMF5AU",296,0) ; code from CORBA ULONG unmarshaling "RTN","XUMF5AU",297,0) Q $A(STR,1)+(256*$A(STR,2))+(65536*$A(STR,3))+(16777216*$A(STR,4)) "RTN","XUMF5AU",298,0) ; "RTN","XUMF5AU",299,0) HEX(STR) ; Printable hex representation of characters in string "RTN","XUMF5AU",300,0) N DIGITS,RET,I,J,BYTE,OFFSET "RTN","XUMF5AU",301,0) S DIGITS="0123456789abcdef" "RTN","XUMF5AU",302,0) S RET="" "RTN","XUMF5AU",303,0) S OFFSET=$L(STR)#4 "RTN","XUMF5AU",304,0) S:OFFSET STR=STR_$E($C(0,0,0),1,4-OFFSET) ; PAD "RTN","XUMF5AU",305,0) F I=0:4:$L(STR)-4 F J=4:-1:1 D ; Reverse byte order in each word "RTN","XUMF5AU",306,0) . S BYTE=$A(STR,I+J) "RTN","XUMF5AU",307,0) . S RET=RET_$E(DIGITS,1+(BYTE\16)) ; High nibble "RTN","XUMF5AU",308,0) . S RET=RET_$E(DIGITS,1+(BYTE#16)) ; Low nibble "RTN","XUMF5AU",309,0) Q RET "RTN","XUMF5AU",310,0) ; "RTN","XUMF5AU",311,0) CHR2OCT(STR) ; convert hex string to decimal byte values "RTN","XUMF5AU",312,0) N RET,I,BYTE,HIGH,LOW "RTN","XUMF5AU",313,0) S RET="" "RTN","XUMF5AU",314,0) F I=1:2:$L(STR) D "RTN","XUMF5AU",315,0) . S BYTE=$E(STR,I,I+1) "RTN","XUMF5AU",316,0) . Q:BYTE'?2NL "RTN","XUMF5AU",317,0) . S HIGH=$$CHAR1($E(BYTE,1)) "RTN","XUMF5AU",318,0) . S LOW=$$CHAR1($E(BYTE,2)) "RTN","XUMF5AU",319,0) . S RET=RET_(16*HIGH+LOW)_" " "RTN","XUMF5AU",320,0) Q RET "RTN","XUMF5AU",321,0) ; "RTN","XUMF5AU",322,0) CHAR1(DIGIT) ; convert one char to its hex value "RTN","XUMF5AU",323,0) N X "RTN","XUMF5AU",324,0) S X=$F("0123456789abcdef",DIGIT) "RTN","XUMF5AU",325,0) Q:X=0 0 "RTN","XUMF5AU",326,0) Q X-2 "RTN","XWBTCPM") 0^23^B56922128 "RTN","XWBTCPM",1,0) XWBTCPM ;ISF/RWF MSC/JDA - BROKER TCP/IP PROCESS HANDLER ;13APR2009 "RTN","XWBTCPM",2,0) ;;1.1;RPC BROKER;**35,43,MSC**;Mar 28, 1997 "RTN","XWBTCPM",3,0) ;Based on: XWBTCPC & XWBTCPL, Modified by ISF/RWF "RTN","XWBTCPM",4,0) ;Changed to be started by UCX or %ZISTCPS "RTN","XWBTCPM",5,0) ; "RTN","XWBTCPM",6,0) ;MSC/JDA 04/13/09 - Added MOREREADTIME to GT.M init "RTN","XWBTCPM",7,0) ; "RTN","XWBTCPM",8,0) DSM ;DSM called from ucx, % passed in with device. "RTN","XWBTCPM",9,0) D ESET "RTN","XWBTCPM",10,0) ;Open the device "RTN","XWBTCPM",11,0) S XWBTDEV=% X "O XWBTDEV:(TCPDEV):60" ;Special UCX/DSM open "RTN","XWBTCPM",12,0) ;Go find the connection type "RTN","XWBTCPM",13,0) U XWBTDEV "RTN","XWBTCPM",14,0) G CONNTYPE "RTN","XWBTCPM",15,0) ; "RTN","XWBTCPM",16,0) CACHEVMS ;Cache'/VMS tcpip entry point, called from XWBTCP_START.COM file "RTN","XWBTCPM",17,0) D ESET "RTN","XWBTCPM",18,0) S XWBTDEV="SYS$NET" "RTN","XWBTCPM",19,0) ; **Cache'/VMS specific code** "RTN","XWBTCPM",20,0) O XWBTDEV::5 "RTN","XWBTCPM",21,0) X "U XWBTDEV:(::""-M"")" ;Packet mode like DSM "RTN","XWBTCPM",22,0) G CONNTYPE "RTN","XWBTCPM",23,0) ; "RTN","XWBTCPM",24,0) NT ;entry from ZISTCPS "RTN","XWBTCPM",25,0) ;JOB LISTEN^%ZISTCPS("port","NT^XWBTCPM","stop code") "RTN","XWBTCPM",26,0) D ESET "RTN","XWBTCPM",27,0) S XWBTDEV=IO "RTN","XWBTCPM",28,0) G CONNTYPE "RTN","XWBTCPM",29,0) ; "RTN","XWBTCPM",30,0) GTMUCX(%) ;From ucx ZFOO "RTN","XWBTCPM",31,0) ;If called from LISTEN^%ZISTCP(PORT,"GTM^XWBTCPM") S XWBTDEV=IO "RTN","XWBTCPM",32,0) D ESET "RTN","XWBTCPM",33,0) S $ZTRAP="" "RTN","XWBTCPM",34,0) ;GTM specific code "RTN","XWBTCPM",35,0) S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""") "RTN","XWBTCPM",36,0) S XWBTDEV=% X "O %:(RECORDSIZE=512)" "RTN","XWBTCPM",37,0) G CONNTYPE "RTN","XWBTCPM",38,0) ; "RTN","XWBTCPM",39,0) GTMLNX ;From Linux xinetd script "RTN","XWBTCPM",40,0) D ESET "RTN","XWBTCPM",41,0) S $ZTRAP="" "RTN","XWBTCPM",42,0) ;GTM specific code "RTN","XWBTCPM",43,0) S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""") "RTN","XWBTCPM",44,0) S XWBTDEV=$P X "U XWBTDEV:(nowrap:nodelimiter)" "RTN","XWBTCPM",45,0) S %="",@("%=$ZTRNLNM(""REMOTE_HOST"")") S:$L(%) IO("GTM-IP")=% "RTN","XWBTCPM",46,0) G CONNTYPE "RTN","XWBTCPM",47,0) ; "RTN","XWBTCPM",48,0) ESET ;Set inital error trap "RTN","XWBTCPM",49,0) S U="^",$ETRAP="D ^%ZTER H" ;Set up the error trap "RTN","XWBTCPM",50,0) Q "RTN","XWBTCPM",51,0) ;Find the type of connection and jump to the processing routine. "RTN","XWBTCPM",52,0) CONNTYPE ; "RTN","XWBTCPM",53,0) N XWBDEBUG,XWBAPVER,XWBCLMAN,XWBENVL,XWBLOG,XWBOS,XWBPTYPE "RTN","XWBTCPM",54,0) N XWBTBUF,XWBTIP,XWBTSKT,XWBVER,XWBWRAP,XWBSHARE,XWBT "RTN","XWBTCPM",55,0) N SOCK,TYPE "RTN","XWBTCPM",56,0) D INIT "RTN","XWBTCPM",57,0) S XWB=$$BREAD^XWBRW(5,XWBTIME) "RTN","XWBTCPM",58,0) D LOG("MSG format is "_XWB_" type "_$S(XWB="[XWB]":"NEW",XWB="{XWB}":"OLD",XWB="0:^XTV(8989.3,1,4,X,0),1:"ROU^y^1") "RTN","XWBTCPM",70,0) I $G(^%ZIS(14.5,"LOGON",XWBVOL)) Q 0 ;Check INHIBIT LOGONS? "RTN","XWBTCPM",71,0) I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(J,U,3),($P(J,U,3)'>Y) Q 0 "RTN","XWBTCPM",72,0) Q 1 "RTN","XWBTCPM",73,0) ; "RTN","XWBTCPM",74,0) M2M ;M2M Broker "RTN","XWBTCPM",75,0) S XWBRBUF=XWB_XWBRBUF,(IO,IO(0))=XWBTDEV G SPAWN^XWBVLL "RTN","XWBTCPM",76,0) Q "RTN","XWBTCPM",77,0) ; "RTN","XWBTCPM",78,0) NEW ;New broker "RTN","XWBTCPM",79,0) S U="^",DUZ=0,DUZ(0)="",XWBVER=1.108 "RTN","XWBTCPM",80,0) D SETTIME(1) ;Setup for sign-on timeout "RTN","XWBTCPM",81,0) U XWBTDEV D "RTN","XWBTCPM",82,0) . N XWB,ERR,NATIP,I "RTN","XWBTCPM",83,0) . S ERR=$$PRSP^XWBPRS "RTN","XWBTCPM",84,0) . S ERR=$$PRSM^XWBPRS "RTN","XWBTCPM",85,0) . S MSG=$G(XWB(4,"CMD")) ;Build connect msg. "RTN","XWBTCPM",86,0) . S I="" F S I=$O(XWB(5,"P",I)) Q:I="" S MSG=MSG_U_XWB(5,"P",I) "RTN","XWBTCPM",87,0) . ;Get the peer and save that IP. "RTN","XWBTCPM",88,0) . S NATIP=$$GETPEER^%ZOSV S:'$L(NATIP) NATIP=$P(MSG,"^",2) "RTN","XWBTCPM",89,0) . I NATIP'=$P(MSG,"^",2) S $P(MSG,"^",2)=NATIP "RTN","XWBTCPM",90,0) . Q "RTN","XWBTCPM",91,0) S X=$$NEWJOB() D:'X LOG("No New Connects") "RTN","XWBTCPM",92,0) I ($P(MSG,U)'="TCPConnect")!('X) D QSND^XWBRW("reject"),LOG("reject: "_MSG) Q "RTN","XWBTCPM",93,0) D QSND^XWBRW("accept"),LOG("accept") ;Ack "RTN","XWBTCPM",94,0) S IO("IP")=$P(MSG,U,2),XWBTSKT=$P(MSG,U,3),XWBCLMAN=$P(MSG,U,4) "RTN","XWBTCPM",95,0) S XWBTIP=$G(IO("IP")) "RTN","XWBTCPM",96,0) ;start RUM for Broker Handler XWB*1.1*5 "RTN","XWBTCPM",97,0) D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1) "RTN","XWBTCPM",98,0) ;GTM "RTN","XWBTCPM",99,0) I $G(XWBT("PCNT")) D "RTN","XWBTCPM",100,0) . S X=$NA(^XUTL("XUSYS",$J,1)) L +@X:0 "RTN","XWBTCPM",101,0) . D COUNT^XUSCNT(1),SETLOCK^XUSCNT(X) "RTN","XWBTCPM",102,0) ;We don't use a callback "RTN","XWBTCPM",103,0) K XWB,CON,LEN,MSG ;Clean up "RTN","XWBTCPM",104,0) ;Attempt to share license, Must have TCP port open first. "RTN","XWBTCPM",105,0) U XWBTDEV ;D SHARELIC^%ZOSV(1) "RTN","XWBTCPM",106,0) ;setup null device "NULL" "RTN","XWBTCPM",107,0) S %ZIS="0H",IOP="NULL" D ^%ZIS S XWBNULL=IO I POP S XWBERROR="No NULL device" D ^%ZTER,EXIT Q "RTN","XWBTCPM",108,0) D SAVDEV^%ZISUTL("XWBNULL") "RTN","XWBTCPM",109,0) ;change process name "RTN","XWBTCPM",110,0) D CHPRN("ip"_$P(XWBTIP,".",3,4)_":"_XWBTDEV) "RTN","XWBTCPM",111,0) ; "RTN","XWBTCPM",112,0) RESTART ;The error trap returns to here "RTN","XWBTCPM",113,0) N $ESTACK S $ETRAP="D ETRAP^XWBTCPM" "RTN","XWBTCPM",114,0) S DT=$$DT^XLFDT,DTIME=30 "RTN","XWBTCPM",115,0) U XWBTDEV D MAIN "RTN","XWBTCPM",116,0) D LOG("Exit: "_XWBTBUF) "RTN","XWBTCPM",117,0) ;Turn off the error trap for the exit "RTN","XWBTCPM",118,0) S $ETRAP="" "RTN","XWBTCPM",119,0) D EXIT ;Logout "RTN","XWBTCPM",120,0) K XWBR,XWBARY "RTN","XWBTCPM",121,0) ;stop RUM for handler XWB*1.1*5 "RTN","XWBTCPM",122,0) D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,2) "RTN","XWBTCPM",123,0) D USE^%ZISUTL("XWBNULL"),CLOSE^%ZISUTL("XWBNULL") "RTN","XWBTCPM",124,0) ;Close in the calling script "RTN","XWBTCPM",125,0) K SOCK,TYPE,XWBSND,XWBTYPE,XWBRBUF "RTN","XWBTCPM",126,0) Q "RTN","XWBTCPM",127,0) ; "RTN","XWBTCPM",128,0) MAIN ; -- main message processing loop. debug at MAIN+1 "RTN","XWBTCPM",129,0) F D Q:XWBTBUF="#BYE#" "RTN","XWBTCPM",130,0) . ;Setup "RTN","XWBTCPM",131,0) . S XWBAPVER=0,XWBTBUF="",XWBTCMD="",XWBRBUF="" "RTN","XWBTCPM",132,0) . K XWBR,XWBARY,XWBPRT "RTN","XWBTCPM",133,0) . ; -- read client request "RTN","XWBTCPM",134,0) . S XR=$$BREAD^XWBRW(1,XWBTIME,1) "RTN","XWBTCPM",135,0) . I '$L(XR) D LOG("Timeout: "_XWBTIME) S XWBTBUF="#BYE#" Q "RTN","XWBTCPM",136,0) . S XR=XR_$$BREAD^XWBRW(4) "RTN","XWBTCPM",137,0) . I XR="#BYE#" D Q ;Check for exit "RTN","XWBTCPM",138,0) . . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF="#BYE#" "RTN","XWBTCPM",139,0) . . Q "RTN","XWBTCPM",140,0) . S TYPE=(XR="[XWB]") ;check HDR "RTN","XWBTCPM",141,0) . I 'TYPE D LOG("Bad Header: "_XR) Q "RTN","XWBTCPM",142,0) . D CALLP^XWBPRS(.XWBR,$G(XWBDEBUG)) ;Read the NEW Msg parameters and call RPC "RTN","XWBTCPM",143,0) . IF XWBTCMD="#BYE#" D Q "RTN","XWBTCPM",144,0) . . D QSND^XWBRW("#BYE#"),LOG("BYE CMD") S XWBTBUF=XWBTCMD "RTN","XWBTCPM",145,0) . . Q "RTN","XWBTCPM",146,0) . U XWBTDEV "RTN","XWBTCPM",147,0) . S XWBPTYPE=$S('$D(XWBPTYPE):1,XWBPTYPE<1:1,XWBPTYPE>6:1,1:XWBPTYPE) "RTN","XWBTCPM",148,0) . ;I $G(XWBPRT) D RETURN^XWBPRS2 Q ;New msg return "RTN","XWBTCPM",149,0) . I '$G(XWBPRT) D SND^XWBRW ;Return data,flush buffer "RTN","XWBTCPM",150,0) Q ;End Of Main "RTN","XWBTCPM",151,0) ; "RTN","XWBTCPM",152,0) ; "RTN","XWBTCPM",153,0) ETRAP ; -- on trapped error, send error info to client "RTN","XWBTCPM",154,0) N XWBERC,XWBERR "RTN","XWBTCPM",155,0) ;Change trapping during trap. "RTN","XWBTCPM",156,0) S $ETRAP="D ^%ZTER,EXIT^XWBTCPM HALT" "RTN","XWBTCPM",157,0) S XWBERC=$E($$EC^%ZOSV,1,200),XWBERR="M ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV "RTN","XWBTCPM",158,0) I $EC["U411" S XWBERROR="U411",XWBSEC="",XWBERR="Data Transfer Error to Server" "RTN","XWBTCPM",159,0) D ^%ZTER ;%ZTER clears $ZE and $ZCODE "RTN","XWBTCPM",160,0) D LOG("In ETRAP: "_XWBERC) ;Log "RTN","XWBTCPM",161,0) I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F") D EXIT HALT "RTN","XWBTCPM",162,0) U XWBTDEV "RTN","XWBTCPM",163,0) I $G(XWBT("PCNT")) L ^XUTL("XUSYS",$J,0) "RTN","XWBTCPM",164,0) E L ;Clear Locks "RTN","XWBTCPM",165,0) ;I XWBOS'="DSM" D "RTN","XWBTCPM",166,0) S XWBPTYPE=1 ;So SNDERR won't check XWBR "RTN","XWBTCPM",167,0) ;D SNDERR^XWBRW,WRITE^XWBRW($C(24)_XWBERR_$C(4)) "RTN","XWBTCPM",168,0) D ESND^XWBRW($C(24)_XWBERR_$C(4)) "RTN","XWBTCPM",169,0) S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" D CLEANP^XWBTCPM G RESTART^XWBTCPM",$ECODE=",U99," "RTN","XWBTCPM",170,0) Q "RTN","XWBTCPM",171,0) ; "RTN","XWBTCPM",172,0) CLEANP ;Clean up the partion "RTN","XWBTCPM",173,0) N XWBTDEV,XWBNULL D KILL^XUSCLEAN "RTN","XWBTCPM",174,0) Q "RTN","XWBTCPM",175,0) ; "RTN","XWBTCPM",176,0) STYPE(X,WRAP) ;For backward compatability only "RTN","XWBTCPM",177,0) I $D(WRAP) Q $$RTRNFMT^XWBLIB($G(X),WRAP) "RTN","XWBTCPM",178,0) Q $$RTRNFMT^XWBLIB(X) "RTN","XWBTCPM",179,0) ; "RTN","XWBTCPM",180,0) BREAD(L,T) ;read tcp buffer, L is length "RTN","XWBTCPM",181,0) Q $$BREAD^XWBRW(L,$G(T)) "RTN","XWBTCPM",182,0) ; "RTN","XWBTCPM",183,0) CHPRN(N) ;change process name "RTN","XWBTCPM",184,0) ;Change process name to N "RTN","XWBTCPM",185,0) D SETNM^%ZOSV($E(N,1,15)) "RTN","XWBTCPM",186,0) Q "RTN","XWBTCPM",187,0) ; "RTN","XWBTCPM",188,0) SETTIME(%) ;Set the Read timeout 0=RPC, 1=sign-on "RTN","XWBTCPM",189,0) S XWBTIME=$S($G(%):90,$G(XWBVER)>1.105:$$BAT^XUPARAM,1:36000),XWBTIME(1)=2 "RTN","XWBTCPM",190,0) I $G(%) S XWBTIME=$S($G(XWBVER)>1.1:90,1:36000) "RTN","XWBTCPM",191,0) Q "RTN","XWBTCPM",192,0) TIMEOUT ;Do this on MAIN loop timeout "RTN","XWBTCPM",193,0) I $G(DUZ)>0 D QSND^XWBRW("#BYE#") Q "RTN","XWBTCPM",194,0) ;Sign-on timeout "RTN","XWBTCPM",195,0) S XWBR(0)=0,XWBR(1)=1,XWBR(2)="",XWBR(3)="TIME-OUT",XWBPTYPE=2 "RTN","XWBTCPM",196,0) D SND^XWBRW "RTN","XWBTCPM",197,0) Q "RTN","XWBTCPM",198,0) ; "RTN","XWBTCPM",199,0) OS() ;Return the OS "RTN","XWBTCPM",200,0) Q $S(^%ZOSF("OS")["DSM":"DSM",^("OS")["UNIX":"UNIX",^("OS")["OpenM":"OpenM",^("OS")["GT.M":"GTM",1:"MSM") "RTN","XWBTCPM",201,0) ; "RTN","XWBTCPM",202,0) INIT ;Setup "RTN","XWBTCPM",203,0) S U="^",XWBTIME=10,XWBOS=$$OS,XWBDEBUG=0,XWBRBUF="" "RTN","XWBTCPM",204,0) S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG") "RTN","XWBTCPM",205,0) S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!") "RTN","XWBTCPM",206,0) X:$D(XWBTDEV)&(XWBOS="GTM") "U XWBTDEV:(MOREREADTIME=999)" "RTN","XWBTCPM",207,0) S XWBT("PCNT")=0 I XWBOS="GT.M",$L($T(^XUSCNT)) S XWBT("PCNT")=1 "RTN","XWBTCPM",208,0) D LOGSTART^XWBDLOG("XWBTCPM") "RTN","XWBTCPM",209,0) Q "RTN","XWBTCPM",210,0) ; "RTN","XWBTCPM",211,0) DEBUG ;Entry point for debug, Build a server to get the connect "RTN","XWBTCPM",212,0) ;DSM sample;ZDEBUG ON S $ZB(1)="SERV+1^XWBTCPM:1",$ZB="ETRAP+1^XWBTCPM:1" "RTN","XWBTCPM",213,0) W !,"Before running this entry point set your debugger to stop at" "RTN","XWBTCPM",214,0) W !,"the place you want to debug. Some spots to use:" "RTN","XWBTCPM",215,0) W !,"'SERV+1^XWBTCPM', 'MAIN+1^XWBTCPM' or 'CAPI+1^XWBPRS.'",! "RTN","XWBTCPM",216,0) W !,"or location of your choice.",! "RTN","XWBTCPM",217,0) W !,"IP Socket to Listen on: " R SOCK:300 Q:'$T!(SOCK["^") "RTN","XWBTCPM",218,0) ;Use %ZISTCP to do a single server "RTN","XWBTCPM",219,0) D LISTEN^%ZISTCP(SOCK,"SERV^XWBTCPM") "RTN","XWBTCPM",220,0) U $P W !,"Done" "RTN","XWBTCPM",221,0) Q "RTN","XWBTCPM",222,0) SERV ;Callback from the server "RTN","XWBTCPM",223,0) S XWBTDEV=IO,XWBTIME(1)=3600 D INIT "RTN","XWBTCPM",224,0) S XWBDEBUG=1,MSG=$$BREAD^XWBRW(5,60) ;R MSG#5 "RTN","XWBTCPM",225,0) D NEW "RTN","XWBTCPM",226,0) S IO("C")=1 ;Cause the Listenr to stop "RTN","XWBTCPM",227,0) Q "RTN","XWBTCPM",228,0) ; "RTN","XWBTCPM",229,0) EXIT ;Close out "RTN","XWBTCPM",230,0) I $G(DUZ) D LOGOUT^XUSRB "RTN","XWBTCPM",231,0) I $G(XWBT("PCNT")) D COUNT^XUSCNT(-1) "RTN","XWBTCPM",232,0) Q "RTN","XWBTCPM",233,0) ; "RTN","XWBTCPM",234,0) LOG(MSG) ;Record Debug Info "RTN","XWBTCPM",235,0) D:$G(XWBDEBUG) LOG^XWBDLOG(MSG) "RTN","XWBTCPM",236,0) Q "RTN","XWBTCPM",237,0) ; "RTN","ZCD") 0^11^B21703984 "RTN","ZCD",1,0) ZCD ; MSC/JKT,JDS ; "Namespace" utilities for GT.M/Unix ; 25JUN2009 "RTN","ZCD",2,0) ;;8.0;KERNEL;**MSC**;April 21 2009 "RTN","ZCD",3,0) ; This routine assumes that your global directory file exists one "RTN","ZCD",4,0) ; directory below the root of the instance, e.g., "RTN","ZCD",5,0) ; "RTN","ZCD",6,0) ; /opt/openvista/instance/globals/mumps.gld "RTN","ZCD",7,0) ; "RTN","ZCD",8,0) ; or "RTN","ZCD",9,0) ; "RTN","ZCD",10,0) ; /home/vista/instance/g/default.gld "RTN","ZCD",11,0) ; "RTN","ZCD",12,0) ; The actual file name of the global directory file and the actual name "RTN","ZCD",13,0) ; of the parent directory are never checked, so their names do not "RTN","ZCD",14,0) ; matter. "RTN","ZCD",15,0) ; "RTN","ZCD",16,0) CD ; interactive "RTN","ZCD",17,0) N Y,DIR "RTN","ZCD",18,0) S:'$D(DTIME) DTIME=300 "RTN","ZCD",19,0) R !,"Namespace: ",DIR:DTIME "RTN","ZCD",20,0) I DIR["^"!(DIR="") Q "RTN","ZCD",21,0) D LIST "RTN","ZCD",22,0) I DIR["?" G HELP "RTN","ZCD",23,0) I '$D(Y("B",DIR)) W !,"Invalid Namespace" G CD "RTN","ZCD",24,0) I $$GTMPATH($$CURRENT())'=$$GTMPATH(DIR) W !,"Inconsistent GTM versions",! G CD "RTN","ZCD",25,0) S A=$$SWITCH(DIR) "RTN","ZCD",26,0) Q "RTN","ZCD",27,0) ; "RTN","ZCD",28,0) HELP N A S A="" "RTN","ZCD",29,0) F S A=$O(Y("B",A)) Q:A="" W !,A "RTN","ZCD",30,0) W ! G CD "RTN","ZCD",31,0) Q "RTN","ZCD",32,0) ; "RTN","ZCD",33,0) ROOT() ; return path where all OpenVista instances live "RTN","ZCD",34,0) Q $P($ZG,"/",1,$L($ZG,"/")-3) "RTN","ZCD",35,0) ; "RTN","ZCD",36,0) CURRENT() ; return name of the current OpenVista instance "RTN","ZCD",37,0) Q $P($ZG,"/",$L($ZG,"/")-2) "RTN","ZCD",38,0) ; "RTN","ZCD",39,0) PATH(INSTANCE) ; return path to an OpenVista instance "RTN","ZCD",40,0) Q $$ROOT()_"/"_INSTANCE "RTN","ZCD",41,0) ; "RTN","ZCD",42,0) GTMPATH(INSTANCE) ; return the path to the version of GT.M this instance uses "RTN","ZCD",43,0) N %PIPE,%I S %PIPE="readlink",%I=$I "RTN","ZCD",44,0) O %PIPE:(COMMAND="readlink "_$$PATH(INSTANCE)_"/gtm":READONLY)::"PIPE" U %PIPE "RTN","ZCD",45,0) N %PATH R %PATH "RTN","ZCD",46,0) U %I "RTN","ZCD",47,0) C %PIPE "RTN","ZCD",48,0) Q %PATH "RTN","ZCD",49,0) ; "RTN","ZCD",50,0) LIST ; return an array (Y) of OpenVista instances on this system "RTN","ZCD",51,0) N %PIPE,%I S %PIPE="ls",%I=$I "RTN","ZCD",52,0) O %PIPE:(COMMAND="ls --color=none -1 "_$$ROOT():READONLY)::"PIPE" U %PIPE "RTN","ZCD",53,0) N I,%NAME K Y "RTN","ZCD",54,0) F I=1:1 R %NAME Q:%NAME="" I $$GTMPATH(%NAME)'="" S Y(I)=%NAME,Y("B",%NAME)="" "RTN","ZCD",55,0) U %I "RTN","ZCD",56,0) C %PIPE "RTN","ZCD",57,0) Q "RTN","ZCD",58,0) ; "RTN","ZCD",59,0) SWITCH(INSTANCE) ; switch to another OpenVista instance "RTN","ZCD",60,0) N %ZG,%ZRO D NEWZGZRO(INSTANCE) I %ZG="",%ZRO="" Q 0 "RTN","ZCD",61,0) ; "RTN","ZCD",62,0) ; FIXME: set gtm_dist="$root/$instance/gtm" "RTN","ZCD",63,0) N %TEMPDIR S %TEMPDIR=$$MKTEMP() S $ZG=%ZG,$ZRO=%ZRO_" "_%TEMPDIR "RTN","ZCD",64,0) N X,Y S X=INSTANCE X ^%ZOSF("UPPERCASE") S $ZPROMPT=Y_">" "RTN","ZCD",65,0) ; FIXME: set GTMXC_openvista="$root/$instance/gtm/openvista.xc" "RTN","ZCD",66,0) ; FIXME: set PATH="$PATH:$root/$instance/gtm" "RTN","ZCD",67,0) ; "RTN","ZCD",68,0) ; re-ZLINK routines that have been loaded in our current image "RTN","ZCD",69,0) X "Q" ; equivalent to ZGOTO so that you can recompile a routine you are using "RTN","ZCD",70,0) N %ROUTINE,%FILENAME S %ROUTINE="" "RTN","ZCD",71,0) NEXT F S %ROUTINE=$VIEW("rtnnext",%ROUTINE) Q:%ROUTINE="" D "RTN","ZCD",72,0) . Q:%ROUTINE="GTM$DMOD" "RTN","ZCD",73,0) . Q:%ROUTINE="ZCD" "RTN","ZCD",74,0) . ; "RTN","ZCD",75,0) . ; The only % routines that we ship start with %Z other % routines are allocated to the "RTN","ZCD",76,0) . ; vendor (GTM) and do not need to be recompiled (and may only have object code) "RTN","ZCD",77,0) . Q:$E(%ROUTINE)="%"&($E(%ROUTINE,2)'="Z") "RTN","ZCD",78,0) . ; "RTN","ZCD",79,0) . ; If the routine exists in the target instance, ZLINK it. This replaces the "RTN","ZCD",80,0) . ; old version in our current image with the new version from the target instance. "RTN","ZCD",81,0) . ; If the routine does not exist in the target instance, we have to "kill" the routine "RTN","ZCD",82,0) . ; in our current image by creating a dummy routine that throws a GTM-E-FILENOTFND error "RTN","ZCD",83,0) . ; and ZLINKing the dummy routine. See http://groups.google.com/group/Hardhats/msg/a213981e1503db79 "RTN","ZCD",84,0) . S %FILENAME=$TR(%ROUTINE,"%","_")_".m" "RTN","ZCD",85,0) . K %ZR D SILENT^%RSEL(%ROUTINE) I '$D(%ZR(%ROUTINE)) D WRITEROU(%TEMPDIR_"/"_%FILENAME,%ROUTINE) "RTN","ZCD",86,0) . ZLINK %FILENAME "RTN","ZCD",87,0) ; "RTN","ZCD",88,0) ; cleanup and return "RTN","ZCD",89,0) S $ZRO=%ZRO ; remove temporary directory from $ZRO "RTN","ZCD",90,0) ZSY "rm -rf "_%TEMPDIR "RTN","ZCD",91,0) Q:'$Q "RTN","ZCD",92,0) Q 1 "RTN","ZCD",93,0) ; "RTN","ZCD",94,0) NEWZGZRO(INSTANCE) ; determine new values of $ZG and $ZRO "RTN","ZCD",95,0) S %ZG="",%ZRO="" "RTN","ZCD",96,0) ; "RTN","ZCD",97,0) ; don't allow switching if GT.M versions aren't the same "RTN","ZCD",98,0) Q:$$GTMPATH($$CURRENT())'=$$GTMPATH(INSTANCE) "RTN","ZCD",99,0) ; "RTN","ZCD",100,0) ; there are several ways to determine new values of $ZG and $ZRO "RTN","ZCD",101,0) ; try each method until one succeeds "RTN","ZCD",102,0) N %METHOD F %METHOD="ENV","CAT","REP" D @("SWITCH"_%METHOD)(INSTANCE) Q:%ZG'=""&(%ZRO'="") "RTN","ZCD",103,0) Q "RTN","ZCD",104,0) ; "RTN","ZCD",105,0) SWITCHENV(INSTANCE) ; private entry point "RTN","ZCD",106,0) ; set new $ZG and $ZRO by parsing env file in target instance "RTN","ZCD",107,0) ; "RTN","ZCD",108,0) ; FIXME: implement this "RTN","ZCD",109,0) Q "RTN","ZCD",110,0) ; "RTN","ZCD",111,0) SWITCHCAT(INSTANCE) ; private entry point "RTN","ZCD",112,0) ; set new $ZG and $ZRO by concatenating conventional names to $$ROOT. "RTN","ZCD",113,0) ; NOTE: this code makes assumptions about the directory layout of the "RTN","ZCD",114,0) ; OpenVista instance. "RTN","ZCD",115,0) ; "RTN","ZCD",116,0) S %ZG=$$PATH(INSTANCE)_"/globals/mumps.gld" "RTN","ZCD",117,0) S %ZRO=$$PATH(INSTANCE)_"/objects("_$$PATH(INSTANCE)_"/routines) "_$$PATH(INSTANCE)_"/gtm" "RTN","ZCD",118,0) ; "RTN","ZCD",119,0) ; FIXME: check that %ZG actually exists and that all pieces of %ZRO exist "RTN","ZCD",120,0) Q "RTN","ZCD",121,0) ; "RTN","ZCD",122,0) SWITCHREP(INSTANCE) ; private entry point "RTN","ZCD",123,0) ; set new $ZG and $ZRO by replacing $$PATH($$CURRENT()) with $$PATH(INSTANCE) "RTN","ZCD",124,0) ; "RTN","ZCD",125,0) ; FIXME: implement this "RTN","ZCD",126,0) Q "RTN","ZCD",127,0) ; "RTN","ZCD",128,0) MKTEMP() ; create a secure temporary directory, returns path to new directory "RTN","ZCD",129,0) N %PIPE,%I S %PIPE="mktemp",%I=$I "RTN","ZCD",130,0) O %PIPE:(COMMAND="mktemp -d -t .zcd.XXXXXXXXXX":READONLY)::"PIPE" U %PIPE "RTN","ZCD",131,0) N %TEMPDIR R %TEMPDIR "RTN","ZCD",132,0) U %I "RTN","ZCD",133,0) C %PIPE "RTN","ZCD",134,0) Q %TEMPDIR "RTN","ZCD",135,0) ; "RTN","ZCD",136,0) WRITEROU(PATH,ROUTINE) ; write out dummy routine "RTN","ZCD",137,0) N %I S %I=$I "RTN","ZCD",138,0) O PATH:(NEWVERSION:NOREADONLY:VARIABLE) U PATH "RTN","ZCD",139,0) W ROUTINE,! "RTN","ZCD",140,0) W " ZMESSAGE 150374338:$PIECE($ZPOSITION,""^"",2)",! "RTN","ZCD",141,0) W " QUIT",! "RTN","ZCD",142,0) U %I "RTN","ZCD",143,0) C PATH "RTN","ZCD",144,0) Q "RTN","ZIS4GTM") 0^5^B18512871 "RTN","ZIS4GTM",1,0) %ZIS4 ;SFISC/AC,RWF,MVB MSC/JDS - DEVICE HANDLER SPECIFIC CODE (GT.M 4.3 for Unix/VMS) ;28MAY2009 "RTN","ZIS4GTM",2,0) ;;8.0;KERNEL;**275,MSC**;Jul 10, 1995; "RTN","ZIS4GTM",3,0) ; "RTN","ZIS4GTM",4,0) OPEN G OPN2:$D(IO(1,IO)) "RTN","ZIS4GTM",5,0) S POP=0 D OP1 G NOPEN:'$D(IO(1,IO)) "RTN","ZIS4GTM",6,0) OPN2 I $D(%ZISHP),'$D(IOP) W !,*7," Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"") "RTN","ZIS4GTM",7,0) Q "RTN","ZIS4GTM",8,0) NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q "RTN","ZIS4GTM",9,0) I '$D(IOP) W *7," [BUSY]" W " ... RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1 "RTN","ZIS4GTM",10,0) S POP=1 Q "RTN","ZIS4GTM",11,0) Q "RTN","ZIS4GTM",12,0) OP1 S X="OPNERR^%ZIS4",@^%ZOSF("TRAP"),$ZE="" "RTN","ZIS4GTM",13,0) L:$D(%ZISLOCK) +@%ZISLOCK:60 "RTN","ZIS4GTM",14,0) O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK "RTN","ZIS4GTM",15,0) Q "RTN","ZIS4GTM",16,0) OPNERR S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" Q "RTN","ZIS4GTM",17,0) ; "RTN","ZIS4GTM",18,0) O D:%IS["L" ZIO "RTN","ZIS4GTM",19,0) LCKGBL ;Lock Global "RTN","ZIS4GTM",20,0) I %ZTYPE="CHAN" N % S %=$G(^%ZIS(1,+%E,"GBL")) I $L(%) L @("+^"_%_":0") S:'$T POP=1 I POP W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q "RTN","ZIS4GTM",21,0) I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX "RTN","ZIS4GTM",22,0) OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR") "RTN","ZIS4GTM",23,0) I %ZTYPE="CHAN",IO["::""TASK="!(IO["SYS$NET") D ODECNET Q:POP G OXECUTE^%ZIS6 "RTN","ZIS4GTM",24,0) S %A=%ZISOPAR_$S(%ZISOPAR["):":"",%ZTYPE["CHAN"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO) "RTN","ZIS4GTM",25,0) N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")") "RTN","ZIS4GTM",26,0) S %A=%_$E(":",%A]"")_%A "RTN","ZIS4GTM",27,0) D O1 I POP D Q "RTN","ZIS4GTM",28,0) .I %ZTYPE="HFS",'$D(IOP),$G(IO("ERROR"))["file not found" W !,?5,*7,"[File Not Found]" Q "RTN","ZIS4GTM",29,0) .W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q "RTN","ZIS4GTM",30,0) ;S IO(1,IO)="" U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) "RTN","ZIS4GTM",31,0) U IO S $X=0,$Y=0 I %ZTYPE["TRM" U IO:(WIDTH=+%Z91) "RTN","ZIS4GTM",32,0) I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1 "RTN","ZIS4GTM",33,0) ;U:%IS'[0 IO(0) "RTN","ZIS4GTM",34,0) G OXECUTE^%ZIS6 "RTN","ZIS4GTM",35,0) Q "RTN","ZIS4GTM",36,0) ; "RTN","ZIS4GTM",37,0) O1 N $ES,$ET S $ET="G OPNERR^%ZIS4" "RTN","ZIS4GTM",38,0) L:$D(%ZISLOCK) +@%ZISLOCK:60 "RTN","ZIS4GTM",39,0) I %A["lpr" S IO="lpr",%A="IO:(COMMAND="_$P(%A,":")_":WRITEONLY)::""PIPE""" "RTN","ZIS4GTM",40,0) O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" L:$D(%ZISLOCK) -@%ZISLOCK "RTN","ZIS4GTM",41,0) S IO("ERROR")="" Q "RTN","ZIS4GTM",42,0) ; "RTN","ZIS4GTM",43,0) ;Need to find out how to get IP address "RTN","ZIS4GTM",44,0) ZIO N %,%1 S (%,%1)=$ZIO "RTN","ZIS4GTM",45,0) I $ZV["VMS",%["_TNA" D "RTN","ZIS4GTM",46,0) . X "S (%,%1)=$ZGETDVI($I,""TT_ACCPORNAM"")" "RTN","ZIS4GTM",47,0) . S %=$S(%["Host:":$P($P(%,"Host: ",2)," ")_":"_$P(%,"Port: ",2),1:%) S:%[" " %=$TR(%," ") "RTN","ZIS4GTM",48,0) I $ZV'["VMS" D "RTN","ZIS4GTM",49,0) . S (%,%1)=$ZTRNLNM("REMOTEHOST") S:$L(%) %1="Host:"_% S:'$L(%) %=$ZIO "RTN","ZIS4GTM",50,0) S IO("ZIO")=% S:(%1["Host:")&'$D(IO("IP")) IO("IP")=$P(%,":") "RTN","ZIS4GTM",51,0) Q "RTN","ZIS4GTM",52,0) ; "RTN","ZIS4GTM",53,0) ODECNET Q ; fill me in later "RTN","ZIS4GTM",54,0) SPOOL ;%ZDA=pointer to ^XMB(3.51, %ZFN=spool file name. "RTN","ZIS4GTM",55,0) I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N "RTN","ZIS4GTM",56,0) I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N "RTN","ZIS4GTM",57,0) R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q")) "RTN","ZIS4GTM",58,0) G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G N:%ZFN']"",DOC "RTN","ZIS4GTM",59,0) S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)="" "RTN","ZIS4GTM",60,0) DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#" "RTN","ZIS4GTM",61,0) I $D(^%ZIS(1,%ZISIOS,1)),$P(^(1),"^",8),$O(^("SPL",0)) S ^XUTL("XQ",$J,"ADSPL")=%ZISIOS,ZISPLAD=%ZISIOS "RTN","ZIS4GTM",62,0) OK K %ZDA,%ZFN Q "RTN","ZIS4GTM",63,0) N K %ZDA,%ZFN,IO("DOC") S POP=1 Q "RTN","ZIS4GTM",64,0) SPL2 O %ZFN:(NEWVERSION:WORLD=RWD) G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q "RTN","ZIS4GTM",65,0) SPL3 N X S X="SPL4^%ZIS4",@^%ZOSF("TRAP") "RTN","ZIS4GTM",66,0) O %ZFN:READONLY:1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q "RTN","ZIS4GTM",67,0) SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q "RTN","ZIS4GTM",68,0) CLOSE N %Z1 C:IO]"" IO K:IO]"" IO(1,IO) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q "RTN","ZIS4GTM",69,0) S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']"" U %ZFN S %ZCR=$C(13),%Y="",X="SPLEOF^%ZIS4",@^%ZOSF("TRAP") "RTN","ZIS4GTM",70,0) S %Z1=+$G(^XTV(8989.3,1,"SPL")) "RTN","ZIS4GTM",71,0) F %=0:0 R %X#255:5 Q:$ZA<0 S %2=%X D CL2 G:%Z1<% SPLEX "RTN","ZIS4GTM",72,0) SPLEOF I $ZE'["ENDO" Q ;Send error up "RTN","ZIS4GTM",73,0) SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q "RTN","ZIS4GTM",74,0) ; "RTN","ZIS4GTM",75,0) CL2 S %=%+1 I %Z1<% S ^XMBS(3.519,XS,2,%,0)="*** INCOMPLETE REPORT -- SPOOL DOCUMENT LINE LIMIT EXCEEDED ***",$P(^XMB(3.51,%ZDA,0),"^",11)=1 Q "RTN","ZIS4GTM",76,0) I %2[$C(12) S ^XMBS(3.519,XS,2,%,0)="|TOP|" Q "RTN","ZIS4GTM",77,0) S ^XMBS(3.519,XS,2,%,0)=%2 Q "RTN","ZIS4GTM",78,0) ; "RTN","ZIS4GTM",79,0) HFS G HFS^%ZISF "RTN","ZIS4GTM",80,0) REWMT(IO,IOPAR) ;Rewind Magtape "RTN","ZIS4GTM",81,0) S X="REWERR^%ZIS4",@^%ZOSF("TRAP") "RTN","ZIS4GTM",82,0) U IO W *5 "RTN","ZIS4GTM",83,0) Q 1 "RTN","ZIS4GTM",84,0) REWSDP(IO,IOPAR) ;Rewind SDP "RTN","ZIS4GTM",85,0) G REW1 "RTN","ZIS4GTM",86,0) REWHFS(IO,IOPAR) ;Rewind Host File. "RTN","ZIS4GTM",87,0) REW1 S X="REWERR^%ZIS4",@^%ZOSF("TRAP") "RTN","ZIS4GTM",88,0) U IO:(REWIND) "RTN","ZIS4GTM",89,0) Q 1 "RTN","ZIS4GTM",90,0) REWERR ;Error encountered "RTN","ZIS4GTM",91,0) Q 0 "RTN","ZISFGTM") 0^48^B9317180 "RTN","ZISFGTM",1,0) %ZISF ;SFISC/AC MSC/JKT - HOST FILES FOR GT.M on Unix/VMS ;27MAY2009 "RTN","ZISFGTM",2,0) ;;8.0;KERNEL;**275**;Jul 10, 1995 "RTN","ZISFGTM",3,0) HFS ;Host File Server "RTN","ZISFGTM",4,0) Q:$D(IOP)&$D(%IS("HFSIO"))&$D(%IS("IOPAR")) "RTN","ZISFGTM",5,0) I $D(%ZIS("HFSNAME")) S IO=%ZIS("HFSNAME"),%X=IO ; "RTN","ZISFGTM",6,0) E D ASKHFS "RTN","ZISFGTM",7,0) S:$D(%ZISOPAR) %ZISOPAR=$$MODE(%ZISOPAR) ;Force conversion to long format, e.g., (NEWVERSION:NOREADONLY:VARIABLE) "RTN","ZISFGTM",8,0) H S:$D(%ZIS("HFSMODE")) %ZISOPAR=$$MODE(%ZIS("HFSMODE")) "RTN","ZISFGTM",9,0) H1 I $D(IO("Q"))!(%IS["Z") S IO("HFSIO")="" "RTN","ZISFGTM",10,0) S IO=$S(%X]"":%X,1:IO),IO=$$CHKNM(IO) ;See that we have a directory "RTN","ZISFGTM",11,0) S:$D(IO("HFSIO")) IO("HFSIO")=IO "RTN","ZISFGTM",12,0) W:'$D(IOP)&$D(%ZIS("HFSNAME")) " HOST FILE TO USE: "_%ZIS("HFSNAME"),! "RTN","ZISFGTM",13,0) D ASKPAR^%ZIS6,SETPAR^%ZIS3 "RTN","ZISFGTM",14,0) HFSIOO I '$D(IOP),%ZTYPE="HFS",'$D(%ZIS("HFSMODE")),'$P(^%ZIS(1,%E,0),"^",4),%ZISOPAR="",$D(^%ZIS(1,%E,1)),$P(^(1),"^",6) W ?45,"INPUT/OUTPUT OPERATION: R//" "RTN","ZISFGTM",15,0) Q:'$T D SBR^%ZIS1 I $D(DTOUT)!$D(DFOUT)!$D(DUOUT) S POP=1 Q "RTN","ZISFGTM",16,0) D HOPT:%X="?"!'$$CHECK(%X),HOPT1:%X="??" G HFSIOO:%X="?"!'$$CHECK(%X) "RTN","ZISFGTM",17,0) S:%X]"" %ZISOPAR="("""_%X_""")" Q "RTN","ZISFGTM",18,0) ; "RTN","ZISFGTM",19,0) CHECK(X) ;Check that we have valid option "RTN","ZISFGTM",20,0) Q $L(X)=1&("ANRW"[X) "RTN","ZISFGTM",21,0) ; "RTN","ZISFGTM",22,0) ASKHFS ;---Ask host file name here--- "RTN","ZISFGTM",23,0) I $D(%IS("B","HFS"))#2,%IS("B","HFS")]"" D "RTN","ZISFGTM",24,0) .S IO=%IS("B","HFS") ;Set default host file name "RTN","ZISFGTM",25,0) S %X='$P($G(^%ZIS(1,%E,1)),"^",5) "RTN","ZISFGTM",26,0) S:'%X %X="" "RTN","ZISFGTM",27,0) I $D(IOP)!%X!$D(%ZIS("HFSNAME")) S %X="" Q "RTN","ZISFGTM",28,0) ASKAGN W !,"HOST FILE NAME: "_IO_"//" D SBR^%ZIS1 "RTN","ZISFGTM",29,0) I %X?1."?".E W !,"ENTER HOST FILE NAME" G ASKAGN "RTN","ZISFGTM",30,0) S:$D(DTOUT)!$D(DUOUT) POP=1 "RTN","ZISFGTM",31,0) Q "RTN","ZISFGTM",32,0) CHKNM(H) ;Check the HFS name "RTN","ZISFGTM",33,0) N N S N=H "RTN","ZISFGTM",34,0) I $ZV["VMS" D "RTN","ZISFGTM",35,0) . I (H'[":")&(H'["[") S N=$$DEFDIR^%ZISH("")_H "RTN","ZISFGTM",36,0) E D "RTN","ZISFGTM",37,0) . I (H'["/") S N=$$DEFDIR^%ZISH("")_H "RTN","ZISFGTM",38,0) Q N "RTN","ZISFGTM",39,0) ; "RTN","ZISFGTM",40,0) MODE(X) ;Return %ZISOPAR "RTN","ZISFGTM",41,0) Q:$E(X)="(" X ;Already in long format "RTN","ZISFGTM",42,0) ; "RTN","ZISFGTM",43,0) ;Strip out invalid codes "RTN","ZISFGTM",44,0) N % F %=1:1:$L(X) I "ANRW"'[$E(X,%) S $E(X,%)=" " "RTN","ZISFGTM",45,0) S X=$TR(X," ") "RTN","ZISFGTM",46,0) ; "RTN","ZISFGTM",47,0) ;Reduce redundant multi-letter combinations to single-letter codes "RTN","ZISFGTM",48,0) I X["N"&(X["W") S X=$TR(X,"W") "RTN","ZISFGTM",49,0) I X["A"&(X["W") S X=$TR(X,"W") "RTN","ZISFGTM",50,0) ; "RTN","ZISFGTM",51,0) ;Take the last code in the string, e.g., if X="AN", the "N" will take effect "RTN","ZISFGTM",52,0) S X=$E(X,$L(X)) "RTN","ZISFGTM",53,0) ; "RTN","ZISFGTM",54,0) ;Translate code into long format "RTN","ZISFGTM",55,0) Q $S(X="N":"(NEWVERSION:NOREADONLY:VARIABLE)",X="W":"(NEWVERSION:NOREADONLY:VARIABLE)",X="A":"(APPEND:NOREADONLY:VARIABLE)",1:"(READONLY:VARIABLE)") "RTN","ZISFGTM",56,0) ; "RTN","ZISFGTM",57,0) HOPT W !,"You may enter a code that represents one of",!,"the following host file input/ouput operation:" "RTN","ZISFGTM",58,0) W !?16,"R = READ ACCESS",!?16,"W = WRITE ACCESS",!?16,"N = NEWVERSION",!?16,"A = APPEND" "RTN","ZISFGTM",59,0) Q "RTN","ZISFGTM",60,0) HOPT1 S %ZISI=$O(^DIC(9.2,"B","XUHFSPARAM-GUX",0)) Q:'%ZISI Q:'$D(^DIC(9.2,+%ZISI,0)) Q:$P(^(0),"^",1)'="XUHFSPARAM-GUX" "RTN","ZISFGTM",61,0) Q:$D(^DIC(9.2,+%ZISI,1))'>9 F %X=0:0 S %X=$O(^DIC(9.2,+%ZISI,1,%X)) Q:%X'>0 I $D(^(%X,0)) W !,^(0) "RTN","ZISFGTM",62,0) W ! S %X="??" Q "RTN","ZISFGUX") 1^27 "RTN","ZISHGUX") 0^15^B36911880 "RTN","ZISHGUX",1,0) %ZISH ;ISF/AC,RWF MSC/JDS- GT.M for UNIX Host file Control ;01MAY2009 "RTN","ZISHGUX",2,0) ;;8.0;KERNEL;**275,306,MSC**;Jul 10, 1995; "RTN","ZISHGUX",3,0) ; for GT.M for Unix/VMS, version 4.3 "RTN","ZISHGUX",4,0) ; "RTN","ZISHGUX",5,0) OPENERR ; "RTN","ZISHGUX",6,0) Q 0 "RTN","ZISHGUX",7,0) ; "RTN","ZISHGUX",8,0) OPEN(X1,X2,X3,X4,X5,X6) ;SR. Open file "RTN","ZISHGUX",9,0) ;D OPEN^%ZISH([handlename],[directory],filename,[accessmode],[recsize]) "RTN","ZISHGUX",10,0) ;X1=handle name "RTN","ZISHGUX",11,0) ;X2=directory, X3=filename, X4=access mode "RTN","ZISHGUX",12,0) ;X5=new file max record size, X6=Subtype "RTN","ZISHGUX",13,0) ; "RTN","ZISHGUX",14,0) N %,%1,%2,%IO,%I2,%P,%T,X,Y,$ETRAP "RTN","ZISHGUX",15,0) S $ETRAP="D OPNERR^%ZISH" "RTN","ZISHGUX",16,0) S U="^",X2=$$DEFDIR($G(X2)),X4=$$UP^XLFSTR(X4) "RTN","ZISHGUX",17,0) S Y=$S(X4["A":"append",X4["R":"readonly",X4["W":"newversion",1:"readonly") "RTN","ZISHGUX",18,0) S Y=Y_$S(X4["B":":fixed:nowrap:recordsize=512",$G(X5)&(X4["W"):":WIDTH="_+X5,1:"") "RTN","ZISHGUX",19,0) S:$E(Y)=":" Y=$E(Y,2,999) S %IO=X2_X3,%I2="%IO:"_$S($L(Y):"("_Y_")",1:"")_":3" "RTN","ZISHGUX",20,0) O @%I2 S %T=$T "RTN","ZISHGUX",21,0) I '%T S POP=1 Q "RTN","ZISHGUX",22,0) S IO=%IO,IO(1,IO)="",IOT="HFS",POP=0 D SUBTYPE^%ZIS3($G(X6)) "RTN","ZISHGUX",23,0) I $G(X1)]"" D SAVDEV^%ZISUTL(X1) "RTN","ZISHGUX",24,0) U IO U $P ;Enable use of $ZA to test EOF condition. "RTN","ZISHGUX",25,0) Q "RTN","ZISHGUX",26,0) OPNERR ;error on open "RTN","ZISHGUX",27,0) S POP=1,$ECODE="" "RTN","ZISHGUX",28,0) U:$G(%P)]"" %P "RTN","ZISHGUX",29,0) Q "RTN","ZISHGUX",30,0) ; "RTN","ZISHGUX",31,0) CLOSE(X) ;SR. Close HFS device not opened by %ZIS. "RTN","ZISHGUX",32,0) ;X1=Handle name, IO=device "RTN","ZISHGUX",33,0) I IO]"" C IO K IO(1,IO) "RTN","ZISHGUX",34,0) I $G(X)]"" D RMDEV^%ZISUTL(X) "RTN","ZISHGUX",35,0) D HOME^%ZIS "RTN","ZISHGUX",36,0) Q "RTN","ZISHGUX",37,0) DEL(%ZX1,%ZX2) ;ef,SR. Del fl(s) "RTN","ZISHGUX",38,0) ;S Y=$$DEL^%ZISH("dir path",$NA(array)) "RTN","ZISHGUX",39,0) N %ZISH,%ZISHLGR,%ZX,X,%ZXDEL "RTN","ZISHGUX",40,0) S %ZX1=$$DEFDIR($G(%ZX1)),%ZXDEL=1,%ZISH="" "RTN","ZISHGUX",41,0) F S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH="" D "RTN","ZISHGUX",42,0) . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH" "RTN","ZISHGUX",43,0) . I %ZISH["*" S %ZXDEL=0 Q ; Wild card not allowed. "RTN","ZISHGUX",44,0) . S %ZX=$ZSEARCH(%ZX1_%ZISH) "RTN","ZISHGUX",45,0) . Q:%ZX']"" ; File doesn't exist - not an error, just quit. "RTN","ZISHGUX",46,0) . O %ZX:READONLY:0 "RTN","ZISHGUX",47,0) . I '$T S %ZXDEL=0 Q ; Can't open it. "RTN","ZISHGUX",48,0) . C %ZX:DELETE "RTN","ZISHGUX",49,0) . I $ZSEARCH(%ZX)]"" S %ZXDEL=0 ; Delete was not successful. "RTN","ZISHGUX",50,0) Q %ZXDEL "RTN","ZISHGUX",51,0) DELERR ;Trap any $ETRAP error, unwind and return. "RTN","ZISHGUX",52,0) S $ETRAP="D UNWIND^%ZTER" "RTN","ZISHGUX",53,0) S %ZXDEL=0 "RTN","ZISHGUX",54,0) D UNWIND^%ZTER "RTN","ZISHGUX",55,0) Q "RTN","ZISHGUX",56,0) ; "RTN","ZISHGUX",57,0) LIST(DIR,LIST,RETURN) ;ef,SR. Set local array holding fl names "RTN","ZISHGUX",58,0) ;S Y=$$LIST^ZISH("/dir/","list_root","return_root") "RTN","ZISHGUX",59,0) ;list_root can have XX("A*"), XX("test.com")... "RTN","ZISHGUX",60,0) ;Both arrays passed as $NA values (closed roots). "RTN","ZISHGUX",61,0) ;Init %ZISHDL1, %ZISHDL2 by deleteing them "RTN","ZISHGUX",62,0) ;I $ZSEARCH(%ZISHDL1)["ZISH" ZSYSTEM "rm "_%ZISHDL1 "RTN","ZISHGUX",63,0) ;I $ZSEARCH(%ZISHDL2)["ZISH" ZSYSTEM "rm "_%ZISHDL2_";*" "RTN","ZISHGUX",64,0) ;Get fls, Build listing in %ZISHDL1 with ls "RTN","ZISHGUX",65,0) S %ZISH1=0,%ZISH="" "RTN","ZISHGUX",66,0) N WANT,GLOB,NAME S WANT="",DIR=$$DEFDIR($G(DIR)) F S WANT=$O(@LIST@(WANT)) Q:WANT="" D "RTN","ZISHGUX",67,0) . S GLOB=DIR_WANT,NAME="" "RTN","ZISHGUX",68,0) . F S NAME=$ZSEARCH(GLOB) Q:NAME="" S @RETURN@($P(NAME,DIR,2))="" "RTN","ZISHGUX",69,0) Q $Q(@RETURN)]"" "RTN","ZISHGUX",70,0) LSTEOF S $ZT="" "RTN","ZISHGUX",71,0) I $L(%IO) U:$D(IO(1,%IO)) IO "RTN","ZISHGUX",72,0) ;C %ZISHDL1 ;:DELETE "RTN","ZISHGUX",73,0) ;I $L($ZSEARCH(%ZISHDL2)) ZSYSTEM "DEL "_%ZISHDL2 "RTN","ZISHGUX",74,0) ;I $L($ZSEARCH(%ZISHDL1)) ZSYSTEM "DEL "_%ZISHDL1_";*" "RTN","ZISHGUX",75,0) S $ECODE="" "RTN","ZISHGUX",76,0) Q ($Q(@%ZX3)]"") "RTN","ZISHGUX",77,0) ; "RTN","ZISHGUX",78,0) LIST1(%ZX,%ZD) ;Get one part of the list "RTN","ZISHGUX",79,0) N $ET,$ES S $ET="D LSTERR^%ZISH" "RTN","ZISHGUX",80,0) ;ZSYSTEM "ls -1 "_%ZX_" > "_%ZISHDL1 "RTN","ZISHGUX",81,0) ;O %ZISHDL1:readonly:1 U %ZISHDL1 "RTN","ZISHGUX",82,0) ;F R %X:1 Q:$ZEOF S @%ZX3@(%X)="" "RTN","ZISHGUX",83,0) ;C %ZISHDL1:DELETE "RTN","ZISHGUX",84,0) N %ZY,%ZI,%ZJ "RTN","ZISHGUX",85,0) S %ZY=$ZSEARCH("*.X") ;Clear vector "RTN","ZISHGUX",86,0) S %ZY=$P(%ZX,"*") "RTN","ZISHGUX",87,0) F S %ZI=$ZSEARCH(%ZX) Q:'$L(%ZI)!(%ZI'[%ZY) S %ZJ=$P(%ZI,%ZD,2),@%ZX3@(%ZJ)="" "RTN","ZISHGUX",88,0) Q 1 "RTN","ZISHGUX",89,0) LSTERR ;Error in list "RTN","ZISHGUX",90,0) I $ZSEARCH(%ZISHDL2)["ZISH" ZSYSTEM "DEL "_%ZISHDL2_";*" "RTN","ZISHGUX",91,0) Q 0 "RTN","ZISHGUX",92,0) ; "RTN","ZISHGUX",93,0) SPAWNERR ;TRAP ERROR OF SPAWN "RTN","ZISHGUX",94,0) O %ZISHDL1:READONLY:1 I $T C %ZISHDL1:DELETE "RTN","ZISHGUX",95,0) S $ECODE="" "RTN","ZISHGUX",96,0) Q 0 "RTN","ZISHGUX",97,0) ; "RTN","ZISHGUX",98,0) MV(X1,X2,Y1,Y2) ;ef,SR. Rename a fl "RTN","ZISHGUX",99,0) ;S Y=$$MV^ZISH("/dir/","fl","/dir/","fl") "RTN","ZISHGUX",100,0) N X,Y,%ZISHDL1 "RTN","ZISHGUX",101,0) S %ZISHDL1="ZISH"_$J_".TMPA",X1=$$DEFDIR($G(X1)),Y1=$$DEFDIR($G(Y1)) "RTN","ZISHGUX",102,0) S $ZT="SPAWNERR^%ZISH" "RTN","ZISHGUX",103,0) ;Pbv or qit "RTN","ZISHGUX",104,0) I (X2="")!(Y2="") Q 0 "RTN","ZISHGUX",105,0) ZSYSTEM "mv "_X1_X2_" "_Y1_Y2 ;Use system command "RTN","ZISHGUX",106,0) S Y=$ZSEARCH(Y1_Y2) "RTN","ZISHGUX",107,0) Q $L(Y)>0 "RTN","ZISHGUX",108,0) ; "RTN","ZISHGUX",109,0) PWD() ;ef,SR. Print working directory "RTN","ZISHGUX",110,0) N Y "RTN","ZISHGUX",111,0) S Y=$$DEFDIR("") "RTN","ZISHGUX",112,0) S:Y="" Y=$ZDIR "RTN","ZISHGUX",113,0) Q Y "RTN","ZISHGUX",114,0) ; "RTN","ZISHGUX",115,0) DEFDIR(DF) ;ef. Default Dir and frmt "RTN","ZISHGUX",116,0) S DF=$G(DF) Q:DF="." "" ;Special way to get current dir. "RTN","ZISHGUX",117,0) S:DF="" DF=$G(^XTV(8989.3,1,"DEV")) "RTN","ZISHGUX",118,0) ;Check syntax, VMS needs : or [ ] "RTN","ZISHGUX",119,0) I ^%ZOSF("OS")["VMS" D Q DF ;***EXIT FOR VMS/GTM "RTN","ZISHGUX",120,0) . N P1,P2 "RTN","ZISHGUX",121,0) . I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2) "RTN","ZISHGUX",122,0) . E S P1="",P2=DF "RTN","ZISHGUX",123,0) . I P1="",P2["$" S DF=P2 Q ;Assume a logical "RTN","ZISHGUX",124,0) . I $L(P2) S:P2'["[" P2="["_P2 S:P2'["]" P2=P2_"]" "RTN","ZISHGUX",125,0) . S DF=P1_P2 "RTN","ZISHGUX",126,0) . Q "RTN","ZISHGUX",127,0) ; "RTN","ZISHGUX",128,0) ;Check syntax, Unix check leading & trailing "/" "RTN","ZISHGUX",129,0) I "./"'[$E(DF) S DF="/"_DF "RTN","ZISHGUX",130,0) I $E(DF,$L(DF))'="/" S DF=DF_"/" "RTN","ZISHGUX",131,0) Q DF "RTN","ZISHGUX",132,0) STATUS() ;ef,SR. Return EOF status "RTN","ZISHGUX",133,0) U $I "RTN","ZISHGUX",134,0) Q $ZEOF "RTN","ZISHGUX",135,0) ; "RTN","ZISHGUX",136,0) EOF(X) ;Eof flag, Pass in $ZA "RTN","ZISHGUX",137,0) Q X "RTN","ZISHGUX",138,0) QL(X) ;Qlfrs "RTN","ZISHGUX",139,0) Q:X="" "RTN","ZISHGUX",140,0) S:$E(X)'="-" X="-"_X "RTN","ZISHGUX",141,0) Q "RTN","ZISHGUX",142,0) FL(X) ;Fl len "RTN","ZISHGUX",143,0) N ZOSHP1,ZOSHP2 "RTN","ZISHGUX",144,0) S ZOSHP1=$P(X,"."),ZOSHP2=$P(X,".",2) "RTN","ZISHGUX",145,0) I $L(ZOSHP1)>14 S X=4 Q "RTN","ZISHGUX",146,0) I $L(ZOSHP2)>8 S X=4 Q "RTN","ZISHGUX",147,0) Q "RTN","ZISHGUX",148,0) ; "RTN","ZISHGUX",149,0) MAKEREF(HF,IX,OVF) ;Internal call to rebuild global ref. "RTN","ZISHGUX",150,0) ;Return %ZISHF,%ZISHO,%ZISHI,%ZISUB "RTN","ZISHGUX",151,0) N I,F,MX "RTN","ZISHGUX",152,0) S OVF=$G(OVF,"%ZISHOF") "RTN","ZISHGUX",153,0) S %ZISHI=$$QS^DDBRAP(HF,IX),MX=$$QL^DDBRAP(HF) ; "RTN","ZISHGUX",154,0) S F=$NA(@HF,IX-1) ;Get first part "RTN","ZISHGUX",155,0) I IX=1 S %ZISHF=F_"(%ZISHI" ;Build root, IX=1 "RTN","ZISHGUX",156,0) I IX>1 S %ZISHF=$E(F,1,$L(F)-1)_",%ZISHI" ;Build root "RTN","ZISHGUX",157,0) S %ZISHO=%ZISHF_","_OVF_",%OVFCNT)" ;Make overflow "RTN","ZISHGUX",158,0) F I=IX+1:1:MX S %ZISHF=%ZISHF_",%ZISUB("_I_")",%ZISUB(I)=$$QS^DDBRAP(HF,I) "RTN","ZISHGUX",159,0) S %ZISHF=%ZISHF_")" "RTN","ZISHGUX",160,0) Q "RTN","ZISHGUX",161,0) FTG(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;ef,SR. Unload contents of host file into global "RTN","ZISHGUX",162,0) ;p1=host file directory "RTN","ZISHGUX",163,0) ;p2=host file name "RTN","ZISHGUX",164,0) ;p3= $NAME REFERENCE INCLUDING STARTING SUBSCRIPT "RTN","ZISHGUX",165,0) ;p4=INCREMENT SUBSCRIPT "RTN","ZISHGUX",166,0) ;p5=Overflow subscript, defaults to "OVF" "RTN","ZISHGUX",167,0) N %ZA,%ZB,%ZC,%ZL,X,%OVFCNT,%CONT "RTN","ZISHGUX",168,0) N I,%ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHLGR,%ZISHOF,%ZISHOX,%ZISHS,%ZX,%ZISHY,POP,%ZISUB,%EXIT "RTN","ZISHGUX",169,0) S %ZX1=$$DEFDIR($G(%ZX1)),%ZISHOF=$G(%ZX5,"OVF") "RTN","ZISHGUX",170,0) D MAKEREF(%ZX3,%ZX4,"%ZISHOF") "RTN","ZISHGUX",171,0) D OPEN^%ZISH(,%ZX1,%ZX2,"R") "RTN","ZISHGUX",172,0) I POP Q 0 "RTN","ZISHGUX",173,0) N $ETRAP S %EXIT=0,$ETRAP="S %ZA=1,%EXIT=1,$ECODE="""" Q" "RTN","ZISHGUX",174,0) U IO F K %XX D READNXT(.%XX) Q:$$EOF(%ZA) D "RTN","ZISHGUX",175,0) . S @%ZISHF=%XX "RTN","ZISHGUX",176,0) . I $D(%XX)>2 F %OVFCNT=1:1 Q:'$D(%XX(%OVFCNT)) S @%ZISHO=%XX(%OVFCNT) "RTN","ZISHGUX",177,0) . S %ZISHI=%ZISHI+1 "RTN","ZISHGUX",178,0) . Q "RTN","ZISHGUX",179,0) D CLOSE() ;Normal exit "RTN","ZISHGUX",180,0) Q '%EXIT "RTN","ZISHGUX",181,0) ; "RTN","ZISHGUX",182,0) ERREOF D CLOSE() ;Got error Reading file "RTN","ZISHGUX",183,0) Q 0 "RTN","ZISHGUX",184,0) ; "RTN","ZISHGUX",185,0) READNXT(REC) ; "RTN","ZISHGUX",186,0) N T,I,X,% "RTN","ZISHGUX",187,0) U IO R X:2 S %ZA=$ZEOF,REC=$E(X,1,255) "RTN","ZISHGUX",188,0) Q:$L(X)<256 "RTN","ZISHGUX",189,0) S %=256 F I=1:1 Q:$L(X)<% S REC(I)=$E(X,%,%+254),%=%+255 "RTN","ZISHGUX",190,0) Q "RTN","ZISHGUX",191,0) GTF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Load contents of global to host file. "RTN","ZISHGUX",192,0) ;Previously name LOAD "RTN","ZISHGUX",193,0) ;p1=$NAME of global reference "RTN","ZISHGUX",194,0) ;p2=incrementing subscript "RTN","ZISHGUX",195,0) ;p3=host file directory "RTN","ZISHGUX",196,0) ;p4=host file name "RTN","ZISHGUX",197,0) N %ZISHY,%ZISHLGR,%ZISHOX "RTN","ZISHGUX",198,0) S %ZISHY=$$MGTF(%ZX1,%ZX2,$G(%ZX3),%ZX4,"W") "RTN","ZISHGUX",199,0) Q %ZISHY "RTN","ZISHGUX",200,0) ; "RTN","ZISHGUX",201,0) GATF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Append to host file. "RTN","ZISHGUX",202,0) ; "RTN","ZISHGUX",203,0) ;p1=$NAME of global reference "RTN","ZISHGUX",204,0) ;p2=incrementing subscript "RTN","ZISHGUX",205,0) ;p3=host file directory "RTN","ZISHGUX",206,0) ;p4=host file name "RTN","ZISHGUX",207,0) N %ZISHY "RTN","ZISHGUX",208,0) S %ZISHY=$$MGTF(%ZX1,%ZX2,$G(%ZX3),%ZX4,"A") "RTN","ZISHGUX",209,0) Q %ZISHY "RTN","ZISHGUX",210,0) ; "RTN","ZISHGUX",211,0) MGTF(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ; "RTN","ZISHGUX",212,0) ;p1=$NAME of global reference "RTN","ZISHGUX",213,0) ;p2=incrementing subscript "RTN","ZISHGUX",214,0) ;p3=host file directory "RTN","ZISHGUX",215,0) ;p4=host file name "RTN","ZISHGUX",216,0) N %ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHLGR,%ZISHS,%ZISHOX,IO,%ZX,Y "RTN","ZISHGUX",217,0) D MAKEREF(%ZX1,%ZX2) "RTN","ZISHGUX",218,0) D OPEN^%ZISH(,%ZX3,%ZX4,%ZX5) ;Default dir set in open "RTN","ZISHGUX",219,0) I POP Q 0 "RTN","ZISHGUX",220,0) N X "RTN","ZISHGUX",221,0) N $ETRAP S $ETRAP="",X="ERREOF^%ZISH",@^%ZOSF("TRAP") "RTN","ZISHGUX",222,0) F Q:'($D(@%ZISHF)#2) S %ZX=@%ZISHF,%ZISHI=%ZISHI+1 U IO W %ZX,! "RTN","ZISHGUX",223,0) D CLOSE() ;Normal Exit "RTN","ZISHGUX",224,0) Q 1 "RTN","ZISHGUX",225,0) ; "RTN","ZISTCPS") 0^25^B18299533 "RTN","ZISTCPS",1,0) %ZISTCPS ;ISF/RWF MSC/JDA - DEVICE HANDLER TCP/IP SERVER CALLS ;22APR2009 "RTN","ZISTCPS",2,0) ;;8.0;KERNEL;**78,118,127,225,275,388,MSC**;Jul 10, 1995 "RTN","ZISTCPS",3,0) Q "RTN","ZISTCPS",4,0) ; "RTN","ZISTCPS",5,0) CLOSE ;Close and reset "RTN","ZISTCPS",6,0) G CLOSE^%ZISTCP "RTN","ZISTCPS",7,0) Q "RTN","ZISTCPS",8,0) ; "RTN","ZISTCPS",9,0) ;In ZRULE, set ZISQUIT=1 to quit "RTN","ZISTCPS",10,0) LISTEN(SOCK,RTN,ZRULE) ;Listen on socket, start routine "RTN","ZISTCPS",11,0) N %A,ZISOS,X,NIO,EXIT "RTN","ZISTCPS",12,0) N $ES,$ET S $ETRAP="D OPNERR^%ZISTCPS" "RTN","ZISTCPS",13,0) S ZISOS=^%ZOSF("OS"),ZRULE=$G(ZRULE) "RTN","ZISTCPS",14,0) S POP=1 "RTN","ZISTCPS",15,0) D GETENV^%ZOSV S U="^",XUENV=Y,XQVOL=$P(Y,U,2) "RTN","ZISTCPS",16,0) S POP=1 D LONT:ZISOS["OpenM",LGTM:ZISOS["GT.M" "RTN","ZISTCPS",17,0) I 'POP C NIO ;Close port "RTN","ZISTCPS",18,0) Q "RTN","ZISTCPS",19,0) ; "RTN","ZISTCPS",20,0) ; "RTN","ZISTCPS",21,0) LONT ;Open port in Accept mode with standard terminators. "RTN","ZISTCPS",22,0) N %ZA,NEWCHAR "RTN","ZISTCPS",23,0) S NIO="|TCP|"_SOCK,EXIT=0 "RTN","ZISTCPS",24,0) ;(adr:sock:term:ibuf:obuf:queue) "RTN","ZISTCPS",25,0) O NIO:(:SOCK:"AT"::512:512:10):30 Q:'$T S POP=0 U NIO "RTN","ZISTCPS",26,0) ;Wait on read for a connect "RTN","ZISTCPS",27,0) LONT2 F U NIO R *NEWCHAR:30 S EXIT=$$EXIT Q:$T!EXIT "RTN","ZISTCPS",28,0) I EXIT C NIO Q "RTN","ZISTCPS",29,0) ;JOB params (:Concurrent Server bit:principal input:principal output) "RTN","ZISTCPS",30,0) J CHILDONT^%ZISTCPS(NIO,RTN):(:16::):10 S %ZA=$ZA "RTN","ZISTCPS",31,0) I %ZA\8196#2=1 W *-2 ;Job failed to clear bit "RTN","ZISTCPS",32,0) G LONT2 "RTN","ZISTCPS",33,0) ; "RTN","ZISTCPS",34,0) CHILDONT(IO,RTN) ;Child process for OpenM "RTN","ZISTCPS",35,0) S $ETRAP="D ^%ZTER L HALT",IO=$ZU(53) "RTN","ZISTCPS",36,0) U IO:(::"-M") ;Work like DSM "RTN","ZISTCPS",37,0) S NEWJOB=$$NEWOK "RTN","ZISTCPS",38,0) I 'NEWJOB W "421 Service temporarily down.",$C(13,10),! "RTN","ZISTCPS",39,0) I NEWJOB K NEWJOB D VAR,@RTN "RTN","ZISTCPS",40,0) HALT "RTN","ZISTCPS",41,0) ; "RTN","ZISTCPS",42,0) VAR ;Setup IO variables "RTN","ZISTCPS",43,0) S IO(0)=IO,IO(1,IO)="",POP=0 "RTN","ZISTCPS",44,0) S IOT="TCP",IOST="P-TCP",IOST(0)=0 "RTN","ZISTCPS",45,0) S IOF=$$FLUSHCHR^%ZISTCP "RTN","ZISTCPS",46,0) S ^XUTL("XQ",$J,0)=$$DT^XLFDT "RTN","ZISTCPS",47,0) Q "RTN","ZISTCPS",48,0) NEWOK() ;Is it OK to start a new process "RTN","ZISTCPS",49,0) I $G(^%ZIS(14.5,"LOGON",^%ZOSF("VOL"))) Q 0 "RTN","ZISTCPS",50,0) I $$AVJ^%ZOSV()<3 Q 0 "RTN","ZISTCPS",51,0) Q 1 "RTN","ZISTCPS",52,0) OPNERR ; "RTN","ZISTCPS",53,0) S POP=1,EXIT=1,IO("ERROR")=$ECODE,$ECODE="" "RTN","ZISTCPS",54,0) Q "RTN","ZISTCPS",55,0) EXIT() ;See if time to exit "RTN","ZISTCPS",56,0) I $$S^%ZTLOAD Q 1 "RTN","ZISTCPS",57,0) N ZISQUIT S ZISQUIT=0 "RTN","ZISTCPS",58,0) I $L(ZRULE) X ZRULE I $G(ZISQUIT) Q 1 "RTN","ZISTCPS",59,0) Q 0 "RTN","ZISTCPS",60,0) ; "RTN","ZISTCPS",61,0) LGTM ;GT.M multi thread server "RTN","ZISTCPS",62,0) N %A K ^TMP("ZISTCP",$J) "RTN","ZISTCPS",63,0) S $ZINTERRUPT="I $$JOBEXAM^ZU($ZPOSITION)" "RTN","ZISTCPS",64,0) S NIO="SCK$"_$S($J>86400:$J,1:84600+$J) ;Construct a dummy, but "unique" devicename for job "RTN","ZISTCPS",65,0) D LOG("Open for Listen "_NIO) "RTN","ZISTCPS",66,0) ;Open the device "RTN","ZISTCPS",67,0) O NIO:(ZLISTEN=SOCK_":TCP":ATTACH="listener"):30:"SOCKET" "RTN","ZISTCPS",68,0) I '$T D LOG("Can't Open Socket: "_SOCK) Q "RTN","ZISTCPS",69,0) U NIO S NIO("ZISTCP",0)=$KEY D LOG("Have port.") "RTN","ZISTCPS",70,0) ;Start Listening "RTN","ZISTCPS",71,0) W /LISTEN(1) S NIO("ZISTCP",1)=$KEY D LOG("Start Listening. "_NIO("ZISTCP",1)) "RTN","ZISTCPS",72,0) N ZC,ZR,IDX,DESC "RTN","ZISTCPS",73,0) S ZC="ZSHOW ""D"":ZR" "RTN","ZISTCPS",74,0) ;Wait for connection "RTN","ZISTCPS",75,0) LG2 S %A=0,EXIT=0 F D Q:%A!EXIT "RTN","ZISTCPS",76,0) . U NIO:(SOCKET="listener") "RTN","ZISTCPS",77,0) . W /WAIT(30) ;Wait for connect "RTN","ZISTCPS",78,0) . I $P($KEY,"|",1)="CONNECT" S NIO("ZISTCP",2)=$KEY,%A=1 "RTN","ZISTCPS",79,0) . S EXIT=$$EXIT "RTN","ZISTCPS",80,0) . Q "RTN","ZISTCPS",81,0) I EXIT C NIO Q "RTN","ZISTCPS",82,0) ; "RTN","ZISTCPS",83,0) S NIO("SOCK")=$P($G(NIO("ZISTCP",2)),"|",2) "RTN","ZISTCPS",84,0) D LOG("Got connection on "_NIO("SOCK")) "RTN","ZISTCPS",85,0) I '$$NEWOK D G LG2 "RTN","ZISTCPS",86,0) . U NIO:(SOCKET=NIO("SOCK")) W "421 Service temporarily down.",$C(13,10),# "RTN","ZISTCPS",87,0) . C NIO:(SOCKET=NIO("SOCK")) K NIO("ZISTCP",2) "RTN","ZISTCPS",88,0) . Q "RTN","ZISTCPS",89,0) ;Find file descriptor "RTN","ZISTCPS",90,0) X ZC "RTN","ZISTCPS",91,0) S DESC="" F IDX=1:1:$O(ZR("D",""),-1) S:ZR("D",IDX)[NIO("SOCK") DESC=$P($P(ZR("D",IDX),"DESC=",2)," ",1) Q:DESC'="" "RTN","ZISTCPS",92,0) I DESC="" D LOG("Can not find file descriptor!") G LG2 "RTN","ZISTCPS",93,0) ;spawn child process "RTN","ZISTCPS",94,0) S SPAWNID=$&openvista.gtmserver(DESC,"GTMLNCH^%ZISTCPS") "RTN","ZISTCPS",95,0) L +^TMP("ZISTCPS",SPAWNID) "RTN","ZISTCPS",96,0) S ^TMP("ZISTCPS",SPAWNID)=RTN "RTN","ZISTCPS",97,0) L -^TMP("ZISTCPS",SPAWNID) "RTN","ZISTCPS",98,0) D LOG("Spawned child "_SPAWNID) "RTN","ZISTCPS",99,0) ;Close the client socket since the child now has it "RTN","ZISTCPS",100,0) C NIO:(SOCKET=NIO("SOCK")) "RTN","ZISTCPS",101,0) G LG2 "RTN","ZISTCPS",102,0) Q "RTN","ZISTCPS",103,0) ; "RTN","ZISTCPS",104,0) GTMLNCH ;Run gt.m job for this connection. "RTN","ZISTCPS",105,0) N RTN S RTN="" "RTN","ZISTCPS",106,0) S IO("GTM-IP")=$P($K,"|",3) "RTN","ZISTCPS",107,0) F D Q:RTN'="" ; Loop until we get entry point "RTN","ZISTCPS",108,0) . L +^TMP("ZISTCPS",$J) ; Get lock that tells us data is ready "RTN","ZISTCPS",109,0) . S RTN=$G(^TMP("ZISTCPS",$J)) ; Get entry point "RTN","ZISTCPS",110,0) . L -^TMP("ZISTCPS",$J) ; release entry point lock "RTN","ZISTCPS",111,0) . H:RTN="" 1 ; We did not get a entry point, so wait a second for server to populate "RTN","ZISTCPS",112,0) . Q "RTN","ZISTCPS",113,0) K ^TMP("ZISTCPS",$J) "RTN","ZISTCPS",114,0) N NIO,SOCK,ZISOS,EXIT,XQVOL,$ETRAP "RTN","ZISTCPS",115,0) S U="^",$ETRAP="D ^%ZTER L HALT" "RTN","ZISTCPS",116,0) S (IO,IO(0))=$P,IO(1,IO)="" "RTN","ZISTCPS",117,0) D VAR,@RTN "RTN","ZISTCPS",118,0) Q "RTN","ZISTCPS",119,0) ; "RTN","ZISTCPS",120,0) LOG(MSG) ;LOG STATUS "RTN","ZISTCPS",121,0) N CNT "RTN","ZISTCPS",122,0) S CNT=$G(^TMP("ZISTCP",$J))+1,^TMP("ZISTCP",$J)=CNT,^($J,CNT)=MSG "RTN","ZISTCPS",123,0) Q "RTN","ZISTCPS",124,0) ; "RTN","ZOSFGUX") 0^14^B22080506 "RTN","ZOSFGUX",1,0) ZOSFGUX ;SFISC/MVB,PUG/TOAD MSC/JDS,JKT- ZOSF Table for GT.M for Unix ;26JUN2009 "RTN","ZOSFGUX",2,0) ;;8.0;KERNEL;**275,MSC**;Jul 10, 1995 "RTN","ZOSFGUX",3,0) ;; for GT.M for Unix, version 4.3 "RTN","ZOSFGUX",4,0) ; "RTN","ZOSFGUX",5,0) S %Y=1,DTIME=$G(DTIME,600) "RTN","ZOSFGUX",6,0) K ^%ZOSF("MASTER"),^%ZOSF("SIGNOFF") "RTN","ZOSFGUX",7,0) I '$D(^%ZOSF("VOL")) S ^%ZOSF("VOL")="ROU" "RTN","ZOSFGUX",8,0) K ZO F I="MGR","PROD","VOL","TMP" S:$D(^%ZOSF(I)) ZO(I)=^%ZOSF(I) "RTN","ZOSFGUX",9,0) F I=1:2 S Z=$P($T(Z+I),";;",2) Q:Z="" S X=$P($T(Z+1+I),";;",2,99) S:Z="OS" $P(^%ZOSF(Z),"^")=X I Z'="OS" S ^%ZOSF(Z)=$S($D(ZO(Z)):ZO(Z),1:X) "RTN","ZOSFGUX",10,0) ; "RTN","ZOSFGUX",11,0) OS S ^%ZOSF("OS")="GT.M (Unix)^19" "RTN","ZOSFGUX",12,0) ; "RTN","ZOSFGUX",13,0) MGR W !,"NAME OF MANAGER'S UCI,VOLUME SET: "_^%ZOSF("MGR")_"// " R X:DTIME I X]"" X ^("UCICHECK") G MGR:0[Y S ^%ZOSF("MGR")=X "RTN","ZOSFGUX",14,0) PROD ; "RTN","ZOSFGUX",15,0) W !,"The value of PRODUCTION will be used in the GETENV api." "RTN","ZOSFGUX",16,0) W !,"PRODUCTION (SIGN-ON) UCI,VOLUME SET: "_^%ZOSF("PROD")_"// " R X:DTIME I X]"" X ^("UCICHECK") G PROD:0[Y S ^%ZOSF("PROD")=X "RTN","ZOSFGUX",17,0) ;See that VOL and PROD agree. "RTN","ZOSFGUX",18,0) I ^%ZOSF("PROD")'[^%ZOSF("VOL") S ^%ZOSF("VOL")=$P(^%ZOSF("PROD"),",",2) "RTN","ZOSFGUX",19,0) VOL W !,"The VOLUME name must match the one in PRODUCTION." "RTN","ZOSFGUX",20,0) W !,"NAME OF VOLUME SET: "_^%ZOSF("VOL")_"//" R X:DTIME "RTN","ZOSFGUX",21,0) I X]"" D I X'?3U W "MUST BE 3 Upper case." G VOL "RTN","ZOSFGUX",22,0) . I ^%ZOSF("PROD")'[X W !,"Must match PRODUCTION" "RTN","ZOSFGUX",23,0) . S:X?3U ^%ZOSF("VOL")=X "RTN","ZOSFGUX",24,0) TMP ;Get the temp directory "RTN","ZOSFGUX",25,0) W !,"The temp directory for the system: '"_^%ZOSF("TMP")_"'//" "RTN","ZOSFGUX",26,0) R X:DTIME I $L(X),X'?1"/".E G TMP "RTN","ZOSFGUX",27,0) I $L(X) S ^%ZOSF("TMP")=X "RTN","ZOSFGUX",28,0) W !,"^%ZOSF setup" "RTN","ZOSFGUX",29,0) Q "RTN","ZOSFGUX",30,0) ; "RTN","ZOSFGUX",31,0) Z ; "RTN","ZOSFGUX",32,0) ;;ACTJ "RTN","ZOSFGUX",33,0) ;;S Y=$$ACTJ^%ZOSV() "RTN","ZOSFGUX",34,0) ;;AVJ "RTN","ZOSFGUX",35,0) ;;S Y=$$AVJ^%ZOSV() "RTN","ZOSFGUX",36,0) ;;BRK "RTN","ZOSFGUX",37,0) ;;U $I:(CENABLE) "RTN","ZOSFGUX",38,0) ;;DEL "RTN","ZOSFGUX",39,0) ;;N %RD,%OD S %RD=$P($S($ZRO["(":$P($P($ZRO,"(",2),")"),1:$ZRO)," ")_"/",%OD=$S($ZRO["(":$P($ZRO,"(",1)_"/",1:%RD) ZSYSTEM "rm -f "_%RD_X_".m" ZSYSTEM "rm -f "_%OD_X_".o" "RTN","ZOSFGUX",40,0) ;;EOFF "RTN","ZOSFGUX",41,0) ;;U $I:(NOECHO) "RTN","ZOSFGUX",42,0) ;;EON "RTN","ZOSFGUX",43,0) ;;U $I:(ECHO) "RTN","ZOSFGUX",44,0) ;;EOT "RTN","ZOSFGUX",45,0) ;;S Y=$ZA\1024#2 ; <===== "RTN","ZOSFGUX",46,0) ;;ERRTN "RTN","ZOSFGUX",47,0) ;;^%ZTER "RTN","ZOSFGUX",48,0) ;;ETRP "RTN","ZOSFGUX",49,0) ;;Q "RTN","ZOSFGUX",50,0) ;;GD "RTN","ZOSFGUX",51,0) ;;G ^%GD "RTN","ZOSFGUX",52,0) ;;$INC "RTN","ZOSFGUX",53,0) ;;0 "RTN","ZOSFGUX",54,0) ;;JOBPARAM "RTN","ZOSFGUX",55,0) ;;G JOBPAR^%ZOSV "RTN","ZOSFGUX",56,0) ;;LABOFF "RTN","ZOSFGUX",57,0) ;;U IO:(NOECHO) ; <===== "RTN","ZOSFGUX",58,0) ;;LOAD "RTN","ZOSFGUX",59,0) ;;D LOAD^%ZOSV2(X) ;S %N=0 F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N^@X) Q:$L(%)=0 S @(DIF_XCNP_",0)")=% "RTN","ZOSFGUX",60,0) ;;LPC "RTN","ZOSFGUX",61,0) ;;S Y="" ; <===== "RTN","ZOSFGUX",62,0) ;;MAGTAPE "RTN","ZOSFGUX",63,0) ;;S %MT("BS")="*1",%MT("FS")="*2",%MT("WTM")="*3",%MT("WB")="*4",%MT("REW")="*5",%MT("RB")="*6",%MT("REL")="*7",%MT("WHL")="*8",%MT("WEL")="*9" ; <===== "RTN","ZOSFGUX",64,0) ;;MAXSIZ "RTN","ZOSFGUX",65,0) ;;Q "RTN","ZOSFGUX",66,0) ;;MGR "RTN","ZOSFGUX",67,0) ;;VAH,ROU "RTN","ZOSFGUX",68,0) ;;MTBOT "RTN","ZOSFGUX",69,0) ;;S Y=$ZA\32#2 ; <===== "RTN","ZOSFGUX",70,0) ;;MTERR "RTN","ZOSFGUX",71,0) ;;S Y=$ZA\32768#2 ; <===== "RTN","ZOSFGUX",72,0) ;;MTONLINE "RTN","ZOSFGUX",73,0) ;;S Y=$ZA\64#2 ; <===== "RTN","ZOSFGUX",74,0) ;;MTWPROT "RTN","ZOSFGUX",75,0) ;;S Y=$ZA\4#2 ; <===== "RTN","ZOSFGUX",76,0) ;;NBRK "RTN","ZOSFGUX",77,0) ;;U $I:(NOCENABLE) "RTN","ZOSFGUX",78,0) ;;NO-PASSALL "RTN","ZOSFGUX",79,0) ;;U $I:(NOPASSTHRU) "RTN","ZOSFGUX",80,0) ;;NO-TYPE-AHEAD "RTN","ZOSFGUX",81,0) ;;U $I:(NOTYPEAHEAD) "RTN","ZOSFGUX",82,0) ;;PASSALL "RTN","ZOSFGUX",83,0) ;;U $I:(PASSTHRU) "RTN","ZOSFGUX",84,0) ;;PRIINQ "RTN","ZOSFGUX",85,0) ;;S Y=$$PRIINQ^%ZOSV() "RTN","ZOSFGUX",86,0) ;;PRIORITY "RTN","ZOSFGUX",87,0) ;;Q ;G PRIORITY^%ZOSV "RTN","ZOSFGUX",88,0) ;;PROD "RTN","ZOSFGUX",89,0) ;;VAH,ROU "RTN","ZOSFGUX",90,0) ;;PROGMODE "RTN","ZOSFGUX",91,0) ;;S Y=$$PROGMODE^%ZOSV() "RTN","ZOSFGUX",92,0) ;;RD "RTN","ZOSFGUX",93,0) ;;G ^%RD "RTN","ZOSFGUX",94,0) ;;RESJOB "RTN","ZOSFGUX",95,0) ;;Q:'$D(DUZ) Q:'$D(^XUSEC("XUMGR",+DUZ)) N XQZ S XQZ="^FORCEX[MGR]" D DO^%XUCI ; <===== "RTN","ZOSFGUX",96,0) ;;RM "RTN","ZOSFGUX",97,0) ;;U $I:WIDTH=$S('X:9999,1:X) "RTN","ZOSFGUX",98,0) ;;RSEL "RTN","ZOSFGUX",99,0) ;;K ^UTILITY($J) D ^%RSEL S X="" X "F S X=$O(%ZR(X)) Q:X="""" S ^UTILITY($J,X)=""""" K %ZR "RTN","ZOSFGUX",100,0) ;;RSUM "RTN","ZOSFGUX",101,0) ;;S Y=0 F %=1,3:1 S %1=$T(+%^@X),%3=$F(%1," ") Q:'%3 S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y "RTN","ZOSFGUX",102,0) ;;SS "RTN","ZOSFGUX",103,0) ;;D ^%SS "RTN","ZOSFGUX",104,0) ;;SAVE "RTN","ZOSFGUX",105,0) ;;D SAVE^%ZOSV2(X) ;N %I,%F S %I=$I,%F=$P($S($ZRO["(":$P($P($ZRO,"(",2),")"),1:$ZRO)," ")_"/"_X_".m" O %F:(NEWVERSION) U %F X "F S XCN=$O(@(DIE_XCN_"")"")) Q:+XCN'=XCN S %=@(DIE_XCN_"",0)"") Q:$E(%,1)=""$"" I $E(%)'="";"" W %,!" C %F U %I "RTN","ZOSFGUX",106,0) ;;SIZE "RTN","ZOSFGUX",107,0) ;;S Y=0 F I=1:1 S %=$T(+I) Q:%="" S Y=Y+$L(%)+2 ; <===== "RTN","ZOSFGUX",108,0) ;;TEST "RTN","ZOSFGUX",109,0) ;;I X]"",$T(^@X)]"" "RTN","ZOSFGUX",110,0) ;;TMK "RTN","ZOSFGUX",111,0) ;;S Y=$ZA\16384#2 "RTN","ZOSFGUX",112,0) ;;TMP "RTN","ZOSFGUX",113,0) ;;/tmp/ "RTN","ZOSFGUX",114,0) ;;TRAP "RTN","ZOSFGUX",115,0) ;;$ZT="G "_X "RTN","ZOSFGUX",116,0) ;;TRMOFF "RTN","ZOSFGUX",117,0) ;;U $I:(TERMINATOR="") "RTN","ZOSFGUX",118,0) ;;TRMON "RTN","ZOSFGUX",119,0) ;;U $I:(TERMINATOR=$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127)) "RTN","ZOSFGUX",120,0) ;;TRMRD "RTN","ZOSFGUX",121,0) ;;S Y=$A($ZB) "RTN","ZOSFGUX",122,0) ;;TYPE-AHEAD "RTN","ZOSFGUX",123,0) ;;U $I:(TYPEAHEAD) "RTN","ZOSFGUX",124,0) ;;UCI "RTN","ZOSFGUX",125,0) ;;S Y=^%ZOSF("PROD") "RTN","ZOSFGUX",126,0) ;;UCICHECK "RTN","ZOSFGUX",127,0) ;;S Y=1 "RTN","ZOSFGUX",128,0) ;;UPPERCASE "RTN","ZOSFGUX",129,0) ;;S Y=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") "RTN","ZOSFGUX",130,0) ;;XY "RTN","ZOSFGUX",131,0) ;;S $X=DX,$Y=DY ; <===== "RTN","ZOSFGUX",132,0) ;;VOL "RTN","ZOSFGUX",133,0) ;;ROU "RTN","ZOSFGUX",134,0) ;;ZD "RTN","ZOSFGUX",135,0) ;;S Y=$$HTE^XLFDT(X,2) I $L($P(Y,"/"))=1 S Y=0_Y "RTN","ZOSV2GTM") 0^13^B6700455 "RTN","ZOSV2GTM",1,0) %ZOSV2 ;ISF/RWF MSC/JDS - More GT.M support routines ;24APR2009 "RTN","ZOSV2GTM",2,0) ;;8.0;KERNEL;**275,MSC**;Jul 10, 1995 "RTN","ZOSV2GTM",3,0) Q "RTN","ZOSV2GTM",4,0) ;SAVE: DIE open array reference. "RTN","ZOSV2GTM",5,0) ; XCN is the starting value to $O from. "RTN","ZOSV2GTM",6,0) SAVE(RN) ;Save a routine "RTN","ZOSV2GTM",7,0) N %,%F,%I,%N,SP,$ETRAP "RTN","ZOSV2GTM",8,0) S $ETRAP="S $ECODE="""" Q" "RTN","ZOSV2GTM",9,0) S %I=$I,SP=" ",%F=$$RTNDIR^%ZOSV()_RN_".m" "RTN","ZOSV2GTM",10,0) O %F:(newversion:noreadonly:blocksize=2048:recordsize=2044) U %F "RTN","ZOSV2GTM",11,0) F S XCN=$O(@(DIE_XCN_")")) Q:XCN'>0 S %=@(DIE_XCN_",0)") Q:$E(%,1)="$" I $E(%)'=";" W $P(%,SP)_$C(9)_$P(%,SP,2,99999),! "RTN","ZOSV2GTM",12,0) C %F ;S %N=$$NULL "RTN","ZOSV2GTM",13,0) ;C %N "RTN","ZOSV2GTM",14,0) U %I "RTN","ZOSV2GTM",15,0) ZLINK RN "RTN","ZOSV2GTM",16,0) Q "RTN","ZOSV2GTM",17,0) NULL() ;Open and use null to hide talking. Return open name "RTN","ZOSV2GTM",18,0) ;Doesn't work for compile errors "RTN","ZOSV2GTM",19,0) N %N S %N=$S($ZV["VMS":"NLA0:",1:"/dev/nul") "RTN","ZOSV2GTM",20,0) O %N U %N "RTN","ZOSV2GTM",21,0) Q %N "RTN","ZOSV2GTM",22,0) ; "RTN","ZOSV2GTM",23,0) DEL(RN) ;Delete a routine file, both source and object. "RTN","ZOSV2GTM",24,0) ; Since the actual routine may be somewhere in a search path, and may be shared "RTN","ZOSV2GTM",25,0) ; with other environments, this places a routine in the first source directory in "RTN","ZOSV2GTM",26,0) ; the search path, which, if executed, generates an error to the effect that the "RTN","ZOSV2GTM",27,0) ; called routine doesn't exist (i.e., it's a way to effect a deletion without "RTN","ZOSV2GTM",28,0) ; actually deleting the routine). "RTN","ZOSV2GTM",29,0) N %N,%DIR,%I,$ETRAP,%F,%O,%S "RTN","ZOSV2GTM",30,0) S $ETRAP="S $ECODE="""" Q" "RTN","ZOSV2GTM",31,0) D SILENT^%RSEL(RN) S %S=%ZR(RN) ; %S now has the directory of the source "RTN","ZOSV2GTM",32,0) D SILENT^%RSEL(RN,"OBJ") S %O=%ZR(RN) ; %O now has the directory of the object "RTN","ZOSV2GTM",33,0) S %DIR=$$RTNDIR^%ZOSV ; %DIR now has the first source directory in $ZRO "RTN","ZOSV2GTM",34,0) S %N=$TR(RN,"%","_") ; %N now has the file name for RN (sans extension) "RTN","ZOSV2GTM",35,0) I $ZPARSE(%S)'=$ZPARSE(%DIR) D "RTN","ZOSV2GTM",36,0) .S %I=$I,%F=%DIR_%N_".m" "RTN","ZOSV2GTM",37,0) .O %F:(NEWVERSION) U %F W " ZM 150374338:$P($ZPOS,""^"",2) Q",! U %I C %F "RTN","ZOSV2GTM",38,0) E ZSY "rm -f "_%S_%N_".m "_%S_%N_".o" "RTN","ZOSV2GTM",39,0) Q "RTN","ZOSV2GTM",40,0) ;LOAD: DIF open array to receive the routine lines. "RTN","ZOSV2GTM",41,0) ; XCNP The starting index -1. "RTN","ZOSV2GTM",42,0) LOAD(RN) ;Load a routine "RTN","ZOSV2GTM",43,0) N % "RTN","ZOSV2GTM",44,0) S %N=0 F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N^@RN) Q:$L(%)=0 S @(DIF_XCNP_",0)")=% "RTN","ZOSV2GTM",45,0) Q "RTN","ZOSV2GTM",46,0) ; "RTN","ZOSV2GTM",47,0) LOAD2(RN) ;Load a routine "RTN","ZOSV2GTM",48,0) N %,%1,%F,%N,$ETRAP "RTN","ZOSV2GTM",49,0) S %I=$I,%F=$$RTNDIR^%ZOSV()_$TR(RN,"%","_")_".m" "RTN","ZOSV2GTM",50,0) O %F:(readonly):1 Q:'$T U %F "RTN","ZOSV2GTM",51,0) F XCNP=XCNP+1:1 R %1:1 Q:'$T!$ZEOF S @(DIF_XCNP_",0)")=$TR(%1,$C(9)," ") "RTN","ZOSV2GTM",52,0) C %F I $L(%I) U %I "RTN","ZOSV2GTM",53,0) Q "RTN","ZOSV2GTM",54,0) ; "RTN","ZOSV2GTM",55,0) RSUM(RN) ;Calculate a RSUM value "RTN","ZOSV2GTM",56,0) N %,DIF,XCNP,%N,Y,$ETRAP K ^TMP("RSUM",$J) "RTN","ZOSV2GTM",57,0) S $ETRAP="S $ECODE="""" Q" "RTN","ZOSV2GTM",58,0) S Y=0,DIF="^TMP(""RSUM"",$J,",XCNP=0 D LOAD2(RN) "RTN","ZOSV2GTM",59,0) F %=1,3:1 S %1=$G(^TMP("RSUM",$J,%,0)),%3=$F(%1," ") Q:'%3 S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y "RTN","ZOSV2GTM",60,0) K ^TMP("RSUM",$J) "RTN","ZOSV2GTM",61,0) Q Y "RTN","ZOSV2GTM",62,0) ; "RTN","ZOSV2GTM",63,0) TEST(RN) ;Special GT.M Test to see if routine is here. "RTN","ZOSV2GTM",64,0) D SILENT^%RSEL(RN) "RTN","ZOSV2GTM",65,0) Q $G(%ZR(RN)) "RTN","ZOSV2GTM",66,0) "RTN","ZOSVGUX") 0^33^B1197142 "RTN","ZOSVGUX",1,0) %ZOSV ;SFISC/AC,PUG/TOAD,HOU/DHW,MSC/JDA/JKT - View commands & special functions. ;23JUN2009 "RTN","ZOSVGUX",2,0) ;;8.0;KERNEL;**275,MSC**;Jul 10, 1995 "RTN","ZOSVGUX",3,0) ; "RTN","ZOSVGUX",4,0) ACTJ() ; # active jobs "RTN","ZOSVGUX",5,0) Q $G(^XUTL("XUSYS",0)) "RTN","ZOSVGUX",6,0) ;This would also work "RTN","ZOSVGUX",7,0) N %FILE S %FILE=$$TEMP_"zosv_actj_"_$J_".tmp" "RTN","ZOSVGUX",8,0) ZSYSTEM "ps cef -C mumps|wc>"_%FILE "RTN","ZOSVGUX",9,0) N %I S %I=$I "RTN","ZOSVGUX",10,0) O %FILE "RTN","ZOSVGUX",11,0) U %FILE R Y U %I "RTN","ZOSVGUX",12,0) C %FILE:DELETE "RTN","ZOSVGUX",13,0) F Q:$E(Y)'=" " S $E(Y)="" "RTN","ZOSVGUX",14,0) S Y=Y-1 "RTN","ZOSVGUX",15,0) Q Y "RTN","ZOSVGUX",16,0) ; "RTN","ZOSVGUX",17,0) RTNDIR() ; primary routine source directory "RTN","ZOSVGUX",18,0) ; If $ZRO is a single directory, e.g., xxx, returns that directory, e.g., xxx/ "RTN","ZOSVGUX",19,0) ; If $ZRO is of the form xxx yyy ... returns xxx/ "RTN","ZOSVGUX",20,0) ; If $ZRO is of the form www(xxx) ... or www(xxx yyy) ... returns xxx/ "RTN","ZOSVGUX",21,0) Q $P($S(($F($ZRO_" "," ")>$F($ZRO,"("))&$F($ZRO,"("):$P($P($ZRO,")"),"(",2),1:$ZRO)," ")_"/" ; "RTN","ZOSVGUX",22,0) TEMP() ; Return path to temp directory "RTN","ZOSVGUX",23,0) ;N %TEMP S %TEMP=$P($$RTNDIR," "),%TEMP=$P(%TEMP,"/",1,$L(%TEMP,"/")-2)_"/t/" "RTN","ZOSVGUX",24,0) Q $G(^%ZOSF("TMP"),"/tmp/") "RTN","ZOSVGUX",25,0) ; "RTN","ZOSVGUX",26,0) AVJ() ; # available jobs "RTN","ZOSVGUX",27,0) Q $G(^%ZTSCH("MAXJOBS"),1000)-$$ACTJ "RTN","ZOSVGUX",28,0) ; "RTN","ZOSVGUX",29,0) PASSALL ; "RTN","ZOSVGUX",30,0) U $I:(PASTHRU) Q ; <===== "RTN","ZOSVGUX",31,0) NOPASS ; "RTN","ZOSVGUX",32,0) U $I:(NOPASTHRU) Q ; <===== "RTN","ZOSVGUX",33,0) ; "RTN","ZOSVGUX",34,0) GETPEER() ;Get the IP address of a connection peer "RTN","ZOSVGUX",35,0) Q $S($L($G(IO("GTM-IP"))):IO("GTM-IP"),1:"") "RTN","ZOSVGUX",36,0) ; "RTN","ZOSVGUX",37,0) LOG(MSG,PRIORITY,TAG) "RTN","ZOSVGUX",38,0) NEW CMD,A "RTN","ZOSVGUX",39,0) S CMD="logger" "RTN","ZOSVGUX",40,0) S:$G(PRIORITY)'="" CMD=CMD_" -p "_PRIORITY "RTN","ZOSVGUX",41,0) S:$G(TAG)'="" CMD=CMD_" -t "_TAG "RTN","ZOSVGUX",42,0) S CMD=CMD_" -- "_MSG "RTN","ZOSVGUX",43,0) S A="LOGDEV" OPEN A:(COMM=CMD)::"PIPE" U A C A "RTN","ZOSVGUX",44,0) Q "RTN","ZOSVGUX",45,0) PRGMODE ; <===== "RTN","ZOSVGUX",46,0) N USER,ISOK,LOGTEXT,RDIR "RTN","ZOSVGUX",47,0) S ISOK=$$AUTH(.USER) "RTN","ZOSVGUX",48,0) Q:USER="^" "RTN","ZOSVGUX",49,0) S RDIR=$$RTNDIR^%ZOSV "RTN","ZOSVGUX",50,0) S LOGTEXT=$S(ISOK:"Granted",1:"Denied")_" programmer mode in " "RTN","ZOSVGUX",51,0) S LOGTEXT=LOGTEXT_$P(RDIR,"/",$L(RDIR,"/")-2) ; instance "RTN","ZOSVGUX",52,0) S LOGTEXT=LOGTEXT_" to "_USER ; Unix acct name "RTN","ZOSVGUX",53,0) S LOGTEXT=LOGTEXT_" from "_$P($ZTRNLNM("SSH_CLIENT")," ",1) ; remote loc "RTN","ZOSVGUX",54,0) S LOGTEXT=LOGTEXT_" logged in as "_$$GET1^DIQ(200,DUZ,.01) ; VistA user "RTN","ZOSVGUX",55,0) D LOG(LOGTEXT,"authpriv.info","OpenVista") "RTN","ZOSVGUX",56,0) I 'ISOK W "??",*7 Q "RTN","ZOSVGUX",57,0) D LOGOPT^XQ12 ;keep in option audit. "RTN","ZOSVGUX",58,0) K XMB,XMTEXT,XMY S XMB="XUPROGMODE",XMB(1)=DUZ,XMB(2)=$I D ^XMB:$L($T(^XMB)) D BYE^XUSCLEAN K ZTPAC,X,XMB "RTN","ZOSVGUX",59,0) ;D UCI S XUCI=Y,XQZ="PRGM^ZUA[MGR]",XUSLNT=1 D DO^%XUCI "RTN","ZOSVGUX",60,0) F BREAK "RTN","ZOSVGUX",61,0) HALT "RTN","ZOSVGUX",62,0) ; "RTN","ZOSVGUX",63,0) PROGMODE() ; <===== "RTN","ZOSVGUX",64,0) Q 1 ; until we fix this, we're never in application mode "RTN","ZOSVGUX",65,0) ; "RTN","ZOSVGUX",66,0) AUTH(USER) ; "RTN","ZOSVGUX",67,0) N PASS "RTN","ZOSVGUX",68,0) N IDDEV S IDDEV="id",OLDIO=$IO "RTN","ZOSVGUX",69,0) O IDDEV:(COMMAND="id -un":READONLY)::"PIPE" U IDDEV R USER C IDDEV U OLDIO "RTN","ZOSVGUX",70,0) Q:USER'="openvista" 1 "RTN","ZOSVGUX",71,0) D INITKB^XGF() "RTN","ZOSVGUX",72,0) W !,"System user name: " "RTN","ZOSVGUX",73,0) S USER=$$READ^XGF() Q:USER="^" 0 "RTN","ZOSVGUX",74,0) X ^%ZOSF("EOFF") "RTN","ZOSVGUX",75,0) W !,"System password: " "RTN","ZOSVGUX",76,0) S PASS=$$READ^XGF() "RTN","ZOSVGUX",77,0) X ^%ZOSF("EON") I PASS="^" S USER="^" Q 0 "RTN","ZOSVGUX",78,0) W ! "RTN","ZOSVGUX",79,0) N DEV,OLDIO,STATUS "RTN","ZOSVGUX",80,0) S DEV="ovauth",OLDIO=$IO,STATUS="Problem opening pipe" "RTN","ZOSVGUX",81,0) O DEV:(COMMAND="/sbin/ovauth "_USER:PARSE:INDEPENDENT:EXCEPTION="G AUTHDONE")::"PIPE" "RTN","ZOSVGUX",82,0) U DEV W PASS R STATUS "RTN","ZOSVGUX",83,0) AUTHDONE "RTN","ZOSVGUX",84,0) U OLDIO "RTN","ZOSVGUX",85,0) C DEV "RTN","ZOSVGUX",86,0) ; W STATUS,! ; Comment this back in to see what went wrong "RTN","ZOSVGUX",87,0) Q STATUS="OK" "RTN","ZOSVGUX",88,0) UCI ; "RTN","ZOSVGUX",89,0) S Y=^%ZOSF("PROD") Q "RTN","ZOSVGUX",90,0) ; "RTN","ZOSVGUX",91,0) UCICHECK(X) ; "RTN","ZOSVGUX",92,0) Q X "RTN","ZOSVGUX",93,0) ; "RTN","ZOSVGUX",94,0) JOBPAR ; <===== "RTN","ZOSVGUX",95,0) ; See if X points to a valid Job. Return its UCI. "RTN","ZOSVGUX",96,0) ; FIXME: currently returns "VAH,ROU" instead of the real UCI (or "" if X is not "RTN","ZOSVGUX",97,0) ; the $J of a mumps process) "RTN","ZOSVGUX",98,0) S Y=$$RETURN("ps c -p "_X_" | tail -1") "RTN","ZOSVGUX",99,0) F Q:$E(Y)'=" " S $E(Y)="" "RTN","ZOSVGUX",100,0) I +Y=X,$E(Y,$L(Y)-4,$L(Y))="mumps" S Y="VAH,ROU" "RTN","ZOSVGUX",101,0) E S Y="" "RTN","ZOSVGUX",102,0) Q "RTN","ZOSVGUX",103,0) ; "RTN","ZOSVGUX",104,0) PRIORITY ; <===== "RTN","ZOSVGUX",105,0) K Y ; Wally has this disabled in general, but I'd like to bring it back "RTN","ZOSVGUX",106,0) Q "RTN","ZOSVGUX",107,0) ; "RTN","ZOSVGUX",108,0) PRIINQ() ; <===== "RTN","ZOSVGUX",109,0) Q 5 ; for now, we're always middle of the road "RTN","ZOSVGUX",110,0) ; "RTN","ZOSVGUX",111,0) BAUD S X="UNKNOWN" Q "RTN","ZOSVGUX",112,0) ; "RTN","ZOSVGUX",113,0) LGR() ; Last global reference ($REFERENCE) "RTN","ZOSVGUX",114,0) Q $R "RTN","ZOSVGUX",115,0) ; "RTN","ZOSVGUX",116,0) EC() ; Error Code: returning $ZS in format more like $ZE from DSM "RTN","ZOSVGUX",117,0) N %ZE "RTN","ZOSVGUX",118,0) I $ZS="" S %ZE="" "RTN","ZOSVGUX",119,0) S %ZE=$P($ZS,",",2)_","_$P($ZS,",",4)_","_$P($ZS,",")_",-"_$P($ZS,",",3) "RTN","ZOSVGUX",120,0) Q %ZE "RTN","ZOSVGUX",121,0) ; "RTN","ZOSVGUX",122,0) DOLRO ;SAVE ENTIRE SYMBOL TABLE IN LOCATION SPECIFIED BY X "RTN","ZOSVGUX",123,0) S Y="%" F S Y=$O(@Y) Q:Y="" D ;code from DEC "RTN","ZOSVGUX",124,0) . I $D(@Y)#2 S @(X_"Y)="_Y) "RTN","ZOSVGUX",125,0) . I $D(@Y)>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR "RTN","ZOSVGUX",126,0) K %X,%Y,Y Q "RTN","ZOSVGUX",127,0) ; "RTN","ZOSVGUX",128,0) ORDER ;SAVE PART OF SYMBOL TABLE IN LOCATION SPECIFIED BY X "RTN","ZOSVGUX",129,0) I Y="*" D DOLRO Q "RTN","ZOSVGUX",130,0) S (Y,Y1)=$P(Y,"*",1) I $D(@Y)=0 F %=0:0 S Y=$O(@Y) Q:Y=""!(Y[Y1) "RTN","ZOSVGUX",131,0) Q:Y="" S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR "RTN","ZOSVGUX",132,0) F %=0:0 S Y=$O(@Y) Q:Y=""!(Y'[Y1) S %=$D(@Y) S:%#2 @(X_"Y)="_Y) I %>9 S %X=Y_"(",%Y=X_"Y," D %XY^%RCR "RTN","ZOSVGUX",133,0) K %,X,Y,Y1 "RTN","ZOSVGUX",134,0) Q "RTN","ZOSVGUX",135,0) ; "RTN","ZOSVGUX",136,0) PARSIZ ; "RTN","ZOSVGUX",137,0) S X=3 Q "RTN","ZOSVGUX",138,0) ; "RTN","ZOSVGUX",139,0) NOLOG ; "RTN","ZOSVGUX",140,0) S Y=0 Q "RTN","ZOSVGUX",141,0) ; "RTN","ZOSVGUX",142,0) GETENV ;Get environment Return Y='UCI^VOL^NODE^BOX LOOKUP' "RTN","ZOSVGUX",143,0) N %HOST,%V S %V=^%ZOSF("PROD"),%HOST=$$RETURN("hostname -s") "RTN","ZOSVGUX",144,0) S Y=$TR(%V,",","^")_"^"_%HOST_"^"_$P(%V,",",2)_":"_%HOST "RTN","ZOSVGUX",145,0) Q "RTN","ZOSVGUX",146,0) ; "RTN","ZOSVGUX",147,0) VERSION(X) ;return OS version, X=1 - return OS "RTN","ZOSVGUX",148,0) Q $S($G(X):$P($ZV," V"),1:+$P($ZV," V",2)) "RTN","ZOSVGUX",149,0) ; "RTN","ZOSVGUX",150,0) SETNM(X) ;Set name, Trap dup's, Fall into SETENV "RTN","ZOSVGUX",151,0) N $ETRAP S $ETRAP="S $ECODE="""" Q" "RTN","ZOSVGUX",152,0) ; "RTN","ZOSVGUX",153,0) SETENV ;Set environment X='PROCESS NAME^ ' "RTN","ZOSVGUX",154,0) S ^XUTL("XUSYS",$J,0)=$H,^("NM")=X ; workaround "RTN","ZOSVGUX",155,0) Q "RTN","ZOSVGUX",156,0) ; "RTN","ZOSVGUX",157,0) SID() ;System ID "RTN","ZOSVGUX",158,0) N J1,T S T="~" "RTN","ZOSVGUX",159,0) S J1(1)=$ZROUTINES,J1(1)=$P(J1(1)," ") "RTN","ZOSVGUX",160,0) S J1(2)=$ZGBLDIR "RTN","ZOSVGUX",161,0) Q "1~"_J1(1)_T_J1(2) "RTN","ZOSVGUX",162,0) ; "RTN","ZOSVGUX",163,0) T0 ; start RT clock <===== "RTN","ZOSVGUX",164,0) Q ; we don't have $ZH on GT.M "RTN","ZOSVGUX",165,0) ; "RTN","ZOSVGUX",166,0) T1 ; store RT datum w/ZHDIF <===== "RTN","ZOSVGUX",167,0) Q ; we don't have $ZH on GT.M "RTN","ZOSVGUX",168,0) ; "RTN","ZOSVGUX",169,0) ZHDIF ;Display dif of two $ZH's <===== "RTN","ZOSVGUX",170,0) W !," CPU=",$J($P(%ZH1,",")-$P(%ZH0,","),6,2) "RTN","ZOSVGUX",171,0) W ?14," ET=",$J($P(%ZH1,",",2)-$P(%ZH0,",",2),6,1) "RTN","ZOSVGUX",172,0) W ?27," DIO=",$J($P(%ZH1,",",7)-$P(%ZH0,",",7),5) "RTN","ZOSVGUX",173,0) W ?40," BIO=",$J($P(%ZH1,",",8)-$P(%ZH0,",",8),5),! ; so far this won't be called "RTN","ZOSVGUX",174,0) Q "RTN","ZOSVGUX",175,0) ; "RTN","ZOSVGUX",176,0) ;Code moved to %ZOSVKR, Comment out if needed. "RTN","ZOSVGUX",177,0) LOGRSRC(OPT,TYPE,STATUS) ;record resource usage in ^XTMP("KMPR" "RTN","ZOSVGUX",178,0) Q:'$G(^%ZTSCH("LOGRSRC")) ; quit if RUM not turned on. "RTN","ZOSVGUX",179,0) ; call to RUM routine. "RTN","ZOSVGUX",180,0) D RU^%ZOSVKR($G(OPT),$G(TYPE),$G(STATUS)) "RTN","ZOSVGUX",181,0) Q "RTN","ZOSVGUX",182,0) ; "RTN","ZOSVGUX",183,0) SETTRM(X) ;Turn on specified terminators. "RTN","ZOSVGUX",184,0) U $I:(TERM=X) "RTN","ZOSVGUX",185,0) Q 1 "RTN","ZOSVGUX",186,0) ; "RTN","ZOSVGUX",187,0) DEVOK ; "RTN","ZOSVGUX",188,0) ;use lsof (list open files) "RTN","ZOSVGUX",189,0) ; given a device name in X "RTN","ZOSVGUX",190,0) ;INPUT: X=Device $I, X1=IOT -- X1 needed for resources "RTN","ZOSVGUX",191,0) ;OUTPUT: Y=0 if available, Y=job # if owned "RTN","ZOSVGUX",192,0) ; Y=-1 if device does not exists. "RTN","ZOSVGUX",193,0) ; return Y=0 if not owned, Y=$J of owning job, Y=999 if dev cycling "RTN","ZOSVGUX",194,0) ; "RTN","ZOSVGUX",195,0) I $G(X1)="RES" G RESOK^%ZIS6 "RTN","ZOSVGUX",196,0) S Y=0 "RTN","ZOSVGUX",197,0) Q ;Let ZIS deal with it. "RTN","ZOSVGUX",198,0) ; "RTN","ZOSVGUX",199,0) N %FILE S %FILE=$$TEMP_"zosv_devok_"_$J_".tmp" "RTN","ZOSVGUX",200,0) ZSYSTEM "/usr/sbin/lsof -F Pc "_X_" >"_%FILE "RTN","ZOSVGUX",201,0) N %I,%X,%Y S %I=$I "RTN","ZOSVGUX",202,0) O %FILE "RTN","ZOSVGUX",203,0) N %I,%X,%Y S %I=$I "RTN","ZOSVGUX",204,0) U %FILE "RTN","ZOSVGUX",205,0) F %Y=0:1 R %X Q:%X="" Q:%X["lsof: status error" D "RTN","ZOSVGUX",206,0) . S %Y(%Y\2,$S($E(%X)="p":"PID",$E(%X)="c":"CMD",1:"?"))=$E(%X,2,$L(%X)) "RTN","ZOSVGUX",207,0) U %I "RTN","ZOSVGUX",208,0) C %FILE:(DELETE) "RTN","ZOSVGUX",209,0) I %X["lsof: status error" S Y=-1 Q "RTN","ZOSVGUX",210,0) S %X="",Y=0 "RTN","ZOSVGUX",211,0) F S %X=$O(%Y(%X)) Q:%X="" I %Y(%X,"CMD")="mumps" S Y=%Y(%X,"PID") Q "RTN","ZOSVGUX",212,0) Q "RTN","ZOSVGUX",213,0) ; "RTN","ZOSVGUX",214,0) PIDOPN ; give a list of of all JOBS that have the current device open "RTN","ZOSVGUX",215,0) ; returns comma separated in Y "RTN","ZOSVGUX",216,0) N %PIPE S %PIPE="lsof" "RTN","ZOSVGUX",217,0) O %PIPE:(COMMAND="lsof -F Pc "_$I:READONLY)::"PIPE" "RTN","ZOSVGUX",218,0) N %I,%X,%Y S %I=$I "RTN","ZOSVGUX",219,0) U %PIPE "RTN","ZOSVGUX",220,0) F %Y=0:1 R %X Q:%X="" S %Y(%Y\2,$S($E(%X)="p":"PID",$E(%X)="c":"CMD",1:"?"))=$E(%X,2,$L(%X)) "RTN","ZOSVGUX",221,0) U %I "RTN","ZOSVGUX",222,0) C %PIPE "RTN","ZOSVGUX",223,0) S (Y,%X)="" F S %X=$O(%Y(%X)) Q:%X="" I %Y(%X,"CMD")="mumps" S Y=Y_","_%Y(%X,"PID") "RTN","ZOSVGUX",224,0) S $E(Y)="" "RTN","ZOSVGUX",225,0) Q "RTN","ZOSVGUX",226,0) ; "RTN","ZOSVGUX",227,0) DEVOPN ;List of Devices opened "RTN","ZOSVGUX",228,0) ;Returns variable Y. Y=Devices owned separated by a comma "RTN","ZOSVGUX",229,0) N %D,%I "RTN","ZOSVGUX",230,0) S Y="" "RTN","ZOSVGUX",231,0) ZSHOW "D":%D "RTN","ZOSVGUX",232,0) S %I="" F S %I=$O(%D("D",%I)) Q:%I="" S Y=Y_","_$P(%D("D",%I)," OPEN ") "RTN","ZOSVGUX",233,0) S $E(Y)="" "RTN","ZOSVGUX",234,0) Q "RTN","ZOSVGUX",235,0) ; "RTN","ZOSVGUX",236,0) RETURN(%COMMAND) ; ** Private Entry Point: execute a shell command & return the resulting value ** "RTN","ZOSVGUX",237,0) ; "RTN","ZOSVGUX",238,0) ; %COMMAND is the string value of the Linux command "RTN","ZOSVGUX",239,0) N %PIPE,%VALUE "RTN","ZOSVGUX",240,0) S %PIPE="pipe" "RTN","ZOSVGUX",241,0) O %PIPE:(COMMAND=%COMMAND:READONLY)::"PIPE" U %PIPE R %VALUE C %PIPE "RTN","ZOSVGUX",242,0) QUIT %VALUE ; return value "RTN","ZOSVGUX",243,0) ; "RTN","ZOSVGUX",244,0) ; "RTN","ZOSVGUX",245,0) STRIPCR(%DIRECTORY) ; ** Private Entry Point: strip extraneous CR from end of lines of all "RTN","ZOSVGUX",246,0) ; routines in %DIRECTORY Linux directory "RTN","ZOSVGUX",247,0) ; "RTN","ZOSVGUX",248,0) ZSYSTEM "perl -pi -e 's/\r\n$/\n/' "_%DIRECTORY_"[A-K]*.m" "RTN","ZOSVGUX",249,0) ZSYSTEM "perl -pi -e 's/\r\n$/\n/' "_%DIRECTORY_"[L-S]*.m" "RTN","ZOSVGUX",250,0) ZSYSTEM "perl -pi -e 's/\r\n$/\n/' "_%DIRECTORY_"[T-z]*.m" "RTN","ZOSVGUX",251,0) ZSYSTEM "perl -pi -e 's/\r\n$/\n/' "_%DIRECTORY_"[_]*.m" "RTN","ZOSVGUX",252,0) Q "RTN","ZOSVGUX",253,0) ; "RTN","ZOSVONT") 0^47^B23474671 "RTN","ZOSVONT",1,0) %ZOSV ;SFISC/AC MSC/REC/JKT - $View commands for Open M for NT. ;1JUN2009 "RTN","ZOSVONT",2,0) ;;8.0;KERNEL;**34,94,107,118,136,215,293,284,385,MSC**;Jul 10, 1995;Build 3 "RTN","ZOSVONT",3,0) ACTJ() ;# Active jobs "RTN","ZOSVONT",4,0) N %,V,Y S V=$$VERSION() "RTN","ZOSVONT",5,0) I V<5 D Q Y "RTN","ZOSVONT",6,0) . S %=0 F Y=0:1 S %=$ZJ(%) Q:%="" "RTN","ZOSVONT",7,0) S Y=$system.License.LUConsumed() "RTN","ZOSVONT",8,0) Q Y "RTN","ZOSVONT",9,0) AVJ() ;# available jobs "RTN","ZOSVONT",10,0) N %,AVJ,ZOSV,port,t,x,v,maxpid,lmflim,$ET "RTN","ZOSVONT",11,0) S v=+$$VERSION() "RTN","ZOSVONT",12,0) ;Cache 3 and 4 "RTN","ZOSVONT",13,0) ;maxpid: from %SS "RTN","ZOSVONT",14,0) I v<5 D Q AVJ "RTN","ZOSVONT",15,0) . S $ET="",maxpid=$v($zu(40,2,118),-2,4) "RTN","ZOSVONT",16,0) . X "S ZOSV=$ZU(5),%=$ZU(5,""%SYS"") S lmflim=$$inquire^LMFCLI,%=$ZU(5,ZOSV)" ;Get the license info "RTN","ZOSVONT",17,0) . ;Add together the enterprise and division licenses avaliable "RTN","ZOSVONT",18,0) . S x=$P(lmflim,";",2)+$P($P(lmflim,"|",2),";",2) "RTN","ZOSVONT",19,0) . S t=+lmflim+$P(lmflim,"|",2) ;Check the license total "RTN","ZOSVONT",20,0) . S AVJ=$S(t")!(^TMP("$ZE",$J,0)["-MEMORY") D "RTN","ZTER",7,0) . I '$D(XUALLOC) D "RTN","ZTER",8,0) . . K (%ZTERLGR,DUZ,DT,DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ,DA,D0,DI,DIC,DIE) "RTN","ZTER",9,0) . S %ZTER12A="ALLOC" "RTN","ZTER",10,0) K XUALLOC "RTN","ZTER",11,0) S %ZTERZE=^TMP("$ZE",$J,0),%ZT("^XUTL(""XQ"",$J)")="" S:'$D(%ZTERLGR) %ZTERLGR=^TMP("$ZE",$J,1) "RTN","ZTER",12,0) G:$$SCREEN(%ZTERZE,1) EXIT ;Let site screen errors, count don't show "RTN","ZTER",13,0) ;Get a record. "RTN","ZTER",14,0) S %ZTERH1=+$H L +^%ZTER(1,%ZTERH1,0):15 "RTN","ZTER",15,0) S %ZTER11N=$P($G(^%ZTER(1,%ZTERH1,0)),"^",2)+1,^%ZTER(1,%ZTERH1,0)=%ZTERH1_"^"_%ZTER11N,^(1,0)="^3.0751^"_%ZTER11N_"^"_%ZTER11N "RTN","ZTER",16,0) I %ZTER11N=1 S ^%ZTER(1,0)=$P(^%ZTER(1,0),"^",1,2)_"^"_%ZTERH1_"^"_($P(^%ZTER(1,0),"^",4)+1) "RTN","ZTER",17,0) L -^%ZTER(1,%ZTERH1,0) "RTN","ZTER",18,0) S %ZTERRT=$NA(^%ZTER(1,%ZTERH1,1,%ZTER11N)) "RTN","ZTER",19,0) S @%ZTERRT@(0)=%ZTER11N,^("ZE")=%ZTERZE S:$D(%ZTERLGR) ^("GR")=%ZTERLGR K %ZTERLGR "RTN","ZTER",20,0) K %ZTER11B "RTN","ZTER",21,0) ;Get $ZB "RTN","ZTER",22,0) I ^%ZOSF("OS")["DSM"!(^%ZOSF("OS")["GT.M") D "RTN","ZTER",23,0) . Q:'$L($ZB) ; rhl/medsphere 20070518 "RTN","ZTER",24,0) . F %ZTER11I=1:1:$L($ZB) S %ZTER11A=$E($ZB,%ZTER11I),%ZTER11B=$G(%ZTER11B)_$S(%ZTER11A?1C:$A(%ZTER11A),1:%ZTER11A)_"," "RTN","ZTER",25,0) . S %ZTER11B=$E(%ZTER11B,1,$L(%ZTER11B)-1) "RTN","ZTER",26,0) . Q "RTN","ZTER",27,0) S:'$D(%ZTER11B) %ZTER11B=$ZB "RTN","ZTER",28,0) S %ZTER11I="" I $D(^%ZOSF("UCI")) K %ZTER11A S:$D(Y) %ZTER11A="" S:($D(Y)#2) %ZTER11A=Y X ^%ZOSF("UCI") S %ZTER11I=Y K:'$D(%ZTER11A) Y S:$D(%ZTER11A) Y=%ZTER11A "RTN","ZTER",29,0) S @%ZTERRT@("H")=$H,^("J")=$J_"^^^"_%ZTER11I_"^"_$J "RTN","ZTER",30,0) S @%ZTERRT@("I")=$I_"^"_$ZA_"^"_%ZTER11B_"^"_$G(IO("ZIO"))_"^"_$X_"^"_$Y_"^"_$P "RTN","ZTER",31,0) S %ZTERROR=$$ETXT "RTN","ZTER",32,0) S %ZTERCNT=0 "RTN","ZTER",33,0) D STACK^%ZTER1 ;Save Special Variables "RTN","ZTER",34,0) D SAVE("$X $Y",$X_" "_$Y) "RTN","ZTER",35,0) I ^%ZOSF("OS")["OpenM" D "RTN","ZTER",36,0) . X "D SAVE(""$ZU(56,2)"",$ZU(56,2))" "RTN","ZTER",37,0) . I $ZV["VMS" S $P(@%ZTERRT@("J"),"^",2,3)=$ZF("GETJPI",$J,"PRCNAM")_"^"_$ZF("GETJPI",$J,"USERNAME") "RTN","ZTER",38,0) D SAVE("$ZV",$ZV) "RTN","ZTER",39,0) ;End Special Variables "RTN","ZTER",40,0) I ^%ZOSF("OS")["VAX DSM" K %ZTER11A,%ZTER11B D VXD^%ZTER1 I 1 "RTN","ZTER",41,0) E D "RTN","ZTER",42,0) . S %ZTERVAR="%" D:$D(%) VAR:$D(%)#2,SUBS:$D(%)>9 "RTN","ZTER",43,0) . F %ZTER11Z=0:0 S %ZTERVAR=$O(@%ZTERVAR) Q:%ZTERVAR="" D VAR:$D(@%ZTERVAR)#2,SUBS:$D(@%ZTERVAR)>9 "RTN","ZTER",44,0) D GLOB "RTN","ZTER",45,0) S:%ZTERCNT>0 @%ZTERRT@("ZV",0)="^3.0752^"_%ZTERCNT_"^"_%ZTERCNT "RTN","ZTER",46,0) S:'$D(^%ZTER(1,"B",%ZTERH1)) ^(%ZTERH1,%ZTERH1)="" "RTN","ZTER",47,0) S ^%ZTER(1,%ZTERH1,1,"B",%ZTER11N,%ZTER11N)="" "RTN","ZTER",48,0) LIN ;Find the line of the error "RTN","ZTER",49,0) S %ZTERY=$P(%ZTERZE,","),%ZTERX=$P(%ZTERY,"^") S:%ZTERX[">" %ZTERX=$P(%ZTERX,">",2) "RTN","ZTER",50,0) I %ZTERX'="" D "RTN","ZTER",51,0) . N X,XCNP,DIF K ^TMP($J,"XTER1") "RTN","ZTER",52,0) . S X=$P($P(%ZTERY,"^",2),":") Q:X="" X ^%ZOSF("TEST") Q:'$T "RTN","ZTER",53,0) . S XCNP=0,DIF="^TMP($J,""XTER1""," X ^%ZOSF("LOAD") S %ZTERY=$P(%ZTERX,"+",1) "RTN","ZTER",54,0) . I %ZTERY'="" F X=0:0 S X=$O(^TMP($J,"XTER1",X)) Q:X'>0 I $P(^(X,0)," ")=%ZTERY S X=X+$P(%ZTERX,"+",2),%ZTZLIN=$G(^TMP($J,"XTER1",X,0)) Q "RTN","ZTER",55,0) . I %ZTERY="" S X=+$P(%ZTERX,"+",2) Q:X'>0 S %ZTZLIN=$G(^TMP($J,"XTER1",X,0)) "RTN","ZTER",56,0) K ^TMP($J,"XTER1") "RTN","ZTER",57,0) S:$D(%ZTZLIN) @%ZTERRT@("LINE")=%ZTZLIN K %ZTZLIN "RTN","ZTER",58,0) I %ZTERROR'="",$D(^%ZTER(2,"B",%ZTERROR)) S %ZTERROR=%ZTERROR_"^"_$P(^%ZTER(2,+$O(^(%ZTERROR,0)),0),"^",2) "RTN","ZTER",59,0) EXIT ; "RTN","ZTER",60,0) I $G(%ZTER12A)["ALLOC" HALT ;Don't allow job to go on. "RTN","ZTER",61,0) S $EC="",$ET=$G(^TMP("$ZE",$J,2)) "RTN","ZTER",62,0) K ^TMP("$ZE",$J) "RTN","ZTER",63,0) K %ZTER11A,%ZTER11B,%ZTERCNT,%ZTER11S,%ZTER11Z,%ZTERVAP,%ZTERVAR,%ZTERSUB,%ZTER11I,%ZTER11D,%ZTER11L,%ZTER11Q,%,%ZTER111,%ZTER112,%ZTER11N "RTN","ZTER",64,0) K %ZTERRT,%ZTERH1 "RTN","ZTER",65,0) Q "RTN","ZTER",66,0) ; "RTN","ZTER",67,0) VAR I "%ZTER"'=$E(%ZTERVAR,1,5) D SAVE(%ZTERVAR,@%ZTERVAR) Q "RTN","ZTER",68,0) S %ZTERCNT=%ZTERCNT+1,@%ZTERRT@("ZV",%ZTERCNT,0)=%ZTERVAR D "RTN","ZTER",69,0) . I $L(@%ZTERVAR)'>255 S @%ZTERRT@("ZV",%ZTERCNT,"D")=@%ZTERVAR Q "RTN","ZTER",70,0) . S @%ZTERRT@("ZV",%ZTERCNT,"D")=" **** VALUE IS GREATER THAN 255 CHARACTERS (SEE SUBNODES FOR DATA) *** " "RTN","ZTER",71,0) . N %ZTER11,%ZTER12 "RTN","ZTER",72,0) . F %ZTER11=1:1 S %ZTER12=$E(@%ZTERVAR,1,245) Q:%ZTER12="" S @%ZTERVAR=$E(@%ZTERVAR,246,$L(@%ZTERVAR)),@%ZTERRT@("ZV",%ZTERCNT,"D",%ZTER11)=%ZTER12 "RTN","ZTER",73,0) . Q "RTN","ZTER",74,0) Q "RTN","ZTER",75,0) ; "RTN","ZTER",76,0) SAVE(%n,%v) ;Save name and value into global, use special variables "RTN","ZTER",77,0) S %ZTERCNT=%ZTERCNT+1,@%ZTERRT@("ZV",%ZTERCNT,0)=%n "RTN","ZTER",78,0) I $L(%v)<256 S @%ZTERRT@("ZV",%ZTERCNT,"D")=%v Q "RTN","ZTER",79,0) ;Variable too long for global node "RTN","ZTER",80,0) S @%ZTERRT@("ZV",%ZTERCNT,"D")=$E(%v,1,255),^("L")=$L(%v) "RTN","ZTER",81,0) N %i S %v=$E(%v,256,$L(%v)) "RTN","ZTER",82,0) F %i=1:1 Q:'$L(%v) S @%ZTERRT@("ZV",%ZTERCNT,"D",%i)=$E(%v,1,255),%v=$E(%v,256,$L(%v)) "RTN","ZTER",83,0) Q "RTN","ZTER",84,0) ; "RTN","ZTER",85,0) SUBS S %ZTER11S="" Q:"%ZT("=$E(%ZTERVAR,1,4) Q:",%ZTER11S,%ZTER11L,"[(","_%ZTERVAR_",") S %ZTERVAP=%ZTERVAR_"(",%ZTERSUB="%ZTER11S)" "RTN","ZTER",86,0) ; "RTN","ZTER",87,0) S %ZTER11S=%ZTERVAR "RTN","ZTER",88,0) F S %ZTER11S=$Q(@%ZTER11S) Q:%ZTER11S="" D SAVE(%ZTER11S,@%ZTER11S) "RTN","ZTER",89,0) Q "RTN","ZTER",90,0) ; "RTN","ZTER",91,0) GLOB ; save off a list of global subtrees, %ZT is passed in subscripted by name "RTN","ZTER",92,0) ; %ZTERCNT passed in to count the nodes we traverse "RTN","ZTER",93,0) ; %ZTERNOD the nodes through which we $QUERY "RTN","ZTER",94,0) ; %ZTERNAM the names of the global subtrees we're saving "RTN","ZTER",95,0) ; %ZTEROPN is %ZTERNAM, evaluated, without close paren for $PIECEing "RTN","ZTER",96,0) N %ZTERNOD,%ZTERNAM,%ZTEROPN "RTN","ZTER",97,0) S %ZTERNAM="" ; the names of the global subtrees we're saving "RTN","ZTER",98,0) F S %ZTERNAM=$O(%ZT(%ZTERNAM)) Q:%ZTERNAM="" D "RTN","ZTER",99,0) . S %ZTERNOD=$NA(@%ZTERNAM) ; fully evaluate all the subscripts (incl. $J) "RTN","ZTER",100,0) . S %ZTEROPN=$E(%ZTERNOD,1,$L(%ZTERNOD)-1) ; save %ZTERNOD w/o close paren "RTN","ZTER",101,0) . ;S %ZTERSUB=$QL(%ZTERNOD) ; how many subscripts in the subtree root's name "RTN","ZTER",102,0) . F S %ZTERNOD=$Q(@%ZTERNOD) Q:%ZTERNOD="" Q:%ZTERNOD'[%ZTEROPN D ; traverse subtree "RTN","ZTER",103,0) . . S %ZTERCNT=%ZTERCNT+1 ; count each node "RTN","ZTER",104,0) . . S @%ZTERRT@("ZV",%ZTERCNT,0)=$P(%ZTERNAM,")")_$P(%ZTERNOD,%ZTEROPN,2) ; unevaluated name "RTN","ZTER",105,0) . . S @%ZTERRT@("ZV",%ZTERCNT,"D")=$G(@%ZTERNOD) ; value of node "RTN","ZTER",106,0) Q "RTN","ZTER",107,0) ; "RTN","ZTER",108,0) ETXT() ;Return the Text of the error "RTN","ZTER",109,0) Q $S(%ZTERZE["%DSM-E":$P($P(%ZTERZE,"%DSM-E-",2),","),1:$P($P(%ZTERZE,"<",2),">")) "RTN","ZTER",110,0) ; "RTN","ZTER",111,0) ERR ;Handle an error in %ZTER "RTN","ZTER",112,0) I $D(%ZTERH1),$D(%ZTER11N) S ^%ZTER(1,%ZTERH1,1,%ZTER11N,"ZE2")="%ZTER error: "_$ECODE "RTN","ZTER",113,0) ;Should ^TMP("$ZE",$J) be killed here "RTN","ZTER",114,0) HALT "RTN","ZTER",115,0) ; "RTN","ZTER",116,0) SCREEN(ERR,%ZT3) ;Screen out certain errors. "RTN","ZTER",117,0) N %ZTE,%ZTI,%ZTJ S:'$D(ERR) ERR=$$EC^%ZOSV "RTN","ZTER",118,0) S %ZTE="",%ZTI=0 "RTN","ZTER",119,0) F %ZTJ=2,1 D Q:%ZTI>0 "RTN","ZTER",120,0) . F %ZTI=0:0 S %ZTI=$O(^%ZTER(2,"AC",%ZTJ,%ZTI)) Q:%ZTI="" S %ZTE=$S($G(^%ZTER(2,%ZTI,2))]"":^(2),1:$P(^(0),"^")) Q:ERR[%ZTE "RTN","ZTER",121,0) . Q "RTN","ZTER",122,0) ;Next see if we should count the error "RTN","ZTER",123,0) I %ZTI>0 S %ZTE=$G(^%ZTER(2,%ZTI,0)) D Q $P(%ZTE,"^",3)=2 ;See if we skip the recording of the error. "RTN","ZTER",124,0) . Q:(%ZTJ=1)&('$G(%ZT3)) "RTN","ZTER",125,0) . I $P(%ZTE,"^",4) L +^%ZTER(2,%ZTI) S ^(3)=$G(^%ZTER(2,%ZTI,3))+1 L -^%ZTER(2,%ZTI) "RTN","ZTER",126,0) . Q "RTN","ZTER",127,0) Q 0 ;record error "RTN","ZTER",128,0) ; "RTN","ZTER",129,0) UNWIND ;Unwind stack for new error trap. Called by app code. "RTN","ZTER",130,0) S $ECODE="" S $ETRAP="D UNW^%ZTER Q:'$QUIT Q -9" S $ECODE=",U1," "RTN","ZTER",131,0) UNW Q:$ESTACK>1 S $ECODE="" Q "RTN","ZTER",132,0) ; "RTN","ZTER",133,0) NEWERR() ;Does this OS support the M95 error trapping "RTN","ZTER",134,0) Q 1 ;All current M system now support 95 error trapping "RTN","ZTER",135,0) N % S %=$G(^%ZOSF("OS")) Q:%="" 0 "RTN","ZTER",136,0) I %["VAX DSM" Q 1 "RTN","ZTER",137,0) I %["GT.M" Q 1 "RTN","ZTER",138,0) I %["MSM",$P($ZV,"Version ",2)'<4.3 Q 1 "RTN","ZTER",139,0) I %["OpenM" Q 1 ;For version >7.0 or NexGen or Cache "RTN","ZTER",140,0) Q 0 "RTN","ZTER",141,0) ABORT ;Pop the stack all the way. "RTN","ZTER",142,0) S $ETRAP="Q:$ST>1 S $ECODE="""" Q" "RTN","ZTER",143,0) Q "RTN","ZTMGRSET") 0^24^B54537333 "RTN","ZTMGRSET",1,0) ZTMGRSET ;SF/RWF,PUG/TOAD,MSC/JDA/JDS/JKT - SET UP THE MGR ACCOUNT FOR THE SYSTEM ;11JUN2009 "RTN","ZTMGRSET",2,0) ;;8.0;KERNEL;**34,36,69,94,121,127,136,191,275,MSC**;JUL 10, 1995; "RTN","ZTMGRSET",3,0) ; "RTN","ZTMGRSET",4,0) N %D,%S,I,OSMAX,U,X,X1,X2,Y,Z1,Z2,ZTOS,ZTMODE,SCR "RTN","ZTMGRSET",5,0) S ZTMODE=0 "RTN","ZTMGRSET",6,0) A W !!,"ZTMGRSET Version ",$P($T(+2),";",3)," ",$P($T(+2),";",5) "RTN","ZTMGRSET",7,0) W !,"HELLO! I exist to assist you in correctly initializing the current account." "RTN","ZTMGRSET",8,0) I $D(^%ZOSF("UCI")) X ^%ZOSF("UCI") I Y'["MG" W $C(7),!!,"THIS MAY NOT BE THE MANAGER UCI.",!," I think it is ",Y,". Should I continue anyway? N//" R X:120 G A:"YNyn"'[$E(X) Q:"Nn"[$E(X) "RTN","ZTMGRSET",9,0) S ZTOS=$$OS() I ZTOS'>0 W !,"Can't determine the OS type. Exiting ZTMGRSET." Q "RTN","ZTMGRSET",10,0) I ZTMODE D I (PCNM<1)!(PCNM>999) W !,"Need a Patch number to load." Q "RTN","ZTMGRSET",11,0) . R !!,"Patch number to load: ",PCNM:120 Q:(PCNM<1)!(PCNM>999) "RTN","ZTMGRSET",12,0) . S SCR="I $P($T(+2^@X),"";"",5)?.E1P1"_$C(34)_PCNM_$C(34)_"1P.E" "RTN","ZTMGRSET",13,0) ; "RTN","ZTMGRSET",14,0) K ^%ZOSF("MASTER"),^("SIGNOFF") ;Remove old nodes. "RTN","ZTMGRSET",15,0) DOIT W !!,"I will now rename a group of routines specific to your operating system." "RTN","ZTMGRSET",16,0) D @ZTOS,ALL,GLOBALS:'ZTMODE W !,"ALL DONE" "RTN","ZTMGRSET",17,0) Q "RTN","ZTMGRSET",18,0) ; "RTN","ZTMGRSET",19,0) RELOAD ;Reload any patched routines "RTN","ZTMGRSET",20,0) N %D,%S,I,OSMAX,U,X,X1,X2,Y,Z1,Z2,ZTOS,ZTMODE,SCR "RTN","ZTMGRSET",21,0) S ZTMODE=1 G A "RTN","ZTMGRSET",22,0) Q "RTN","ZTMGRSET",23,0) ; "RTN","ZTMGRSET",24,0) OS() ;Select the OS "RTN","ZTMGRSET",25,0) N Y,X1,X "RTN","ZTMGRSET",26,0) S U="^",SCR="I 1" F I=1:1:20 S X=$T(@I) Q:X="" S OSMAX=I "RTN","ZTMGRSET",27,0) B S Y=0,ZTOS=0 I $D(^%ZOSF("OS")) D "RTN","ZTMGRSET",28,0) . S X1=$P(^%ZOSF("OS"),U),ZTOS=$$OSNUM W !,"I think you are using ",X1 "RTN","ZTMGRSET",29,0) W !,"Which MUMPS system should I install?",! "RTN","ZTMGRSET",30,0) F I=1:1:OSMAX W !,I," = ",$P($T(@I),";",3) "RTN","ZTMGRSET",31,0) W !,"System: " W:ZTOS ZTOS,"//" "RTN","ZTMGRSET",32,0) R X:300 S:X="" X=ZTOS "RTN","ZTMGRSET",33,0) I X<1!(X>OSMAX) W !,"NOT A VALID CHOICE" Q:X[U 0 G B "RTN","ZTMGRSET",34,0) Q X "RTN","ZTMGRSET",35,0) ; "RTN","ZTMGRSET",36,0) OSNUM() ;Return the OS number "RTN","ZTMGRSET",37,0) N I,X1,X2,Y S Y=0,X1=$P($G(^%ZOSF("OS")),"^") "RTN","ZTMGRSET",38,0) F I=1:1 S X2=$T(@I) Q:X2="" I X2[X1 S Y=I Q "RTN","ZTMGRSET",39,0) Q Y "RTN","ZTMGRSET",40,0) ; "RTN","ZTMGRSET",41,0) ALL W !!,"Now to load routines common to all systems." "RTN","ZTMGRSET",42,0) D TM,ETRAP,DEV,OTHER,FM "RTN","ZTMGRSET",43,0) I ZTOS=7!(ZTOS=8) D "RTN","ZTMGRSET",44,0) . S ^%ZE="D ^ZE" "RTN","ZTMGRSET",45,0) E D ;With ZLoad, ZSave, ZInsert "RTN","ZTMGRSET",46,0) . W !,"Installing ^%Z editor" "RTN","ZTMGRSET",47,0) . D ^ZTEDIT "RTN","ZTMGRSET",48,0) I 'ZTMODE W !,"Setting ^%ZIS('C')" K ^%ZIS("C") S ^%ZIS("C")="G ^%ZISC" "RTN","ZTMGRSET",49,0) Q "RTN","ZTMGRSET",50,0) ; "RTN","ZTMGRSET",51,0) TM ;Taskman "RTN","ZTMGRSET",52,0) S %S="ZTLOAD^ZTLOAD1^ZTLOAD2^ZTLOAD3^ZTLOAD4^ZTLOAD5^ZTLOAD6^ZTLOAD7" "RTN","ZTMGRSET",53,0) S %D="%ZTLOAD^%ZTLOAD1^%ZTLOAD2^%ZTLOAD3^%ZTLOAD4^%ZTLOAD5^%ZTLOAD6^%ZTLOAD7" "RTN","ZTMGRSET",54,0) D MOVE "RTN","ZTMGRSET",55,0) S %S="ZTM^ZTM0^ZTM1^ZTM2^ZTM3^ZTM4^ZTM5^ZTM6" "RTN","ZTMGRSET",56,0) S %D="%ZTM^%ZTM0^%ZTM1^%ZTM2^%ZTM3^%ZTM4^%ZTM5^%ZTM6" "RTN","ZTMGRSET",57,0) D MOVE "RTN","ZTMGRSET",58,0) S %S="ZTMS^ZTMS0^ZTMS1^ZTMS2^ZTMS3^ZTMS4^ZTMS5^ZTMS7^ZTMSH" "RTN","ZTMGRSET",59,0) ;I ZTOS=7!(ZTOS=8) S $P(%S,U,1)="ZTMSGTM" "RTN","ZTMGRSET",60,0) S %D="%ZTMS^%ZTMS0^%ZTMS1^%ZTMS2^%ZTMS3^%ZTMS4^%ZTMS5^%ZTMS7^%ZTMSH" "RTN","ZTMGRSET",61,0) D MOVE "RTN","ZTMGRSET",62,0) Q "RTN","ZTMGRSET",63,0) FM ;Rename the FileMan routines "RTN","ZTMGRSET",64,0) I ZTMODE=1 Q ;Only ask on full install "RTN","ZTMGRSET",65,0) R !,"Want to rename the FileMan routines: No//",X:600 Q:"Yy"'[$E(X_"N") "RTN","ZTMGRSET",66,0) S %S="DIDT^DIDTC^DIRCR",%D="%DT^%DTC^%RCR" "RTN","ZTMGRSET",67,0) D MOVE "RTN","ZTMGRSET",68,0) Q "RTN","ZTMGRSET",69,0) ; "RTN","ZTMGRSET",70,0) ETRAP ;Error Trap "RTN","ZTMGRSET",71,0) S %S="ZTER^ZTER1",%D="%ZTER^%ZTER1" "RTN","ZTMGRSET",72,0) D MOVE "RTN","ZTMGRSET",73,0) Q "RTN","ZTMGRSET",74,0) OTHER S %S="ZTPP^ZTP1^ZTPTCH^ZTRDEL^ZTMOVE" "RTN","ZTMGRSET",75,0) S %D="%ZTPP^%ZTP1^%ZTPTCH^%ZTRDEL^%ZTMOVE" "RTN","ZTMGRSET",76,0) D MOVE "RTN","ZTMGRSET",77,0) Q "RTN","ZTMGRSET",78,0) DEV S %S="ZIS^ZIS1^ZIS2^ZIS3^ZIS5^ZIS6^ZIS7^ZISC^ZISP^ZISS^ZISS1^ZISS2^ZISTCP^ZISUTL" "RTN","ZTMGRSET",79,0) S %D="%ZIS^%ZIS1^%ZIS2^%ZIS3^%ZIS5^%ZIS6^%ZIS7^%ZISC^%ZISP^%ZISS^%ZISS1^%ZISS2^%ZISTCP^%ZISUTL" "RTN","ZTMGRSET",80,0) D MOVE "RTN","ZTMGRSET",81,0) Q "RTN","ZTMGRSET",82,0) RUM ;Build the routines for Capacity Management (CM) "RTN","ZTMGRSET",83,0) S %S="" "RTN","ZTMGRSET",84,0) I ZTOS=1 S %S="ZOSVKRV^ZOSVKSVE^ZOSVKSVS^ZOSVKSD" ;DSM "RTN","ZTMGRSET",85,0) I ZTOS=2 S %S="ZOSVKRM^ZOSVKSME^ZOSVKSMS^ZOSVKSD" ;MSM "RTN","ZTMGRSET",86,0) I ZTOS=3 S %S="ZOSVKRO^ZOSVKSOE^ZOSVKSOS^ZOSVKSD" ;OpenM "RTN","ZTMGRSET",87,0) I ZTOS=7!(ZTOS=8) S %S="ZOSVKRG^ZOSVKSGE^ZOSVKSGS^ZOSVKSD" ;GT.M "RTN","ZTMGRSET",88,0) S %D="%ZOSVKR^%ZOSVKSE^%ZOSVKSS^%ZOSVKSD" "RTN","ZTMGRSET",89,0) D MOVE "RTN","ZTMGRSET",90,0) Q "RTN","ZTMGRSET",91,0) ZOSF(X) ; "RTN","ZTMGRSET",92,0) X SCR I $T W ! D @(U_X) W ! "RTN","ZTMGRSET",93,0) Q "RTN","ZTMGRSET",94,0) 1 ;;VAX DSM(V6), VAX DSM(V7) "RTN","ZTMGRSET",95,0) S %S="ZOSVVXD^ZTBKCVXD^ZIS4VXD^ZISFVXD^ZISHVXD^XUCIVXD^ZISETVXD" "RTN","ZTMGRSET",96,0) D DES,MOVE "RTN","ZTMGRSET",97,0) S %S="ZOSV2VXD^ZTMDCL",%D="%ZOSV2^%ZTMDCL" "RTN","ZTMGRSET",98,0) D MOVE,RUM,ZOSF("ZOSFVXD") "RTN","ZTMGRSET",99,0) Q "RTN","ZTMGRSET",100,0) 2 ;;MSM-PC/PLUS, MSM for NT or UNIX "RTN","ZTMGRSET",101,0) W !,"- Use autostart to do ZTMB don't resave as STUSER." "RTN","ZTMGRSET",102,0) S %S="ZOSVMSM^ZTBKCMSM^ZIS4MSM^ZISFMSM^ZISHMSM^XUCIMSM^ZISETMSM" "RTN","ZTMGRSET",103,0) D DES,MOVE "RTN","ZTMGRSET",104,0) S %S="ZOSV2MSM",%D="%ZOSV2" "RTN","ZTMGRSET",105,0) D MOVE,RUM,ZOSF("ZOSFMSM") "RTN","ZTMGRSET",106,0) I $$VERSION^%ZOSV(1)["UNIX" S %S="ZISHMSU",%D="%ZISH" D MOVE "RTN","ZTMGRSET",107,0) Q "RTN","ZTMGRSET",108,0) 3 ;;OpenM for NT, Cache/NT, Cache/VMS "RTN","ZTMGRSET",109,0) S %S="ZOSVONT^^ZIS4ONT^ZISFONT^ZISHONT^XUCIONT" "RTN","ZTMGRSET",110,0) D DES,MOVE "RTN","ZTMGRSET",111,0) S %S="ZISTCPS",%D="%ZISTCPS" "RTN","ZTMGRSET",112,0) D MOVE,RUM,ZOSF("ZOSFONT") "RTN","ZTMGRSET",113,0) Q "RTN","ZTMGRSET",114,0) 4 ;;Datatree, DTM-PC, DT-MAX "RTN","ZTMGRSET",115,0) S %S="ZOSVDTM^ZTBKCDTM^ZIS4DTM^ZISFDTM^ZISHDTM^XUCIDTM^ZISETDTM" "RTN","ZTMGRSET",116,0) D DES,MOVE "RTN","ZTMGRSET",117,0) S %S="ZOSV1DTM^ZTMB",%D="%ZOSV1^%ustart" "RTN","ZTMGRSET",118,0) D MOVE,ZOSF("ZOSFDTM") "RTN","ZTMGRSET",119,0) Q "RTN","ZTMGRSET",120,0) 5 ;;MVX,ISM VAX "RTN","ZTMGRSET",121,0) S %S="ZOSVMSQ^ZTBKCMSQ^ZIS4MSQ^ZISFMSQ^ZISHMSQ^XUCIMSQ^ZISETMSQ" "RTN","ZTMGRSET",122,0) D DES,MOVE "RTN","ZTMGRSET",123,0) S %S="ZTMB",%D="ZSTU" "RTN","ZTMGRSET",124,0) D MOVE,ZOSF("ZOSFMSQ") "RTN","ZTMGRSET",125,0) Q "RTN","ZTMGRSET",126,0) 6 ;;ISM (UNIX, Open VMS) "RTN","ZTMGRSET",127,0) S %S="ZOSVIS2^^ZIS4IS2^ZISFIS2^ZISHIS2^XUCIIS2^ZISETIS2" "RTN","ZTMGRSET",128,0) D DES,MOVE "RTN","ZTMGRSET",129,0) S %S="ZTMB",%D="ZSTU" "RTN","ZTMGRSET",130,0) D MOVE,ZOSF("ZOSFIS2") "RTN","ZTMGRSET",131,0) Q "RTN","ZTMGRSET",132,0) 7 ;;GT.M (VMS) "RTN","ZTMGRSET",133,0) S %S="ZOSVGTM^ZTBKCGTM^ZIS4GTM^ZISFGTM^ZISHGTM^XUCIGTM^ZISETGTM" "RTN","ZTMGRSET",134,0) D DES,MOVE "RTN","ZTMGRSET",135,0) S %S="ZOSV2GTM^ZISTCPS",%D="%ZOSV2^%ZISTCPS" "RTN","ZTMGRSET",136,0) D MOVE,ZOSF("ZOSFGTM") "RTN","ZTMGRSET",137,0) Q "RTN","ZTMGRSET",138,0) 8 ;;GT.M (Unix) "RTN","ZTMGRSET",139,0) S %S="ZOSVGUX^ZBBKCGUZ^ZIS4GTM^ZISFGTM^ZISHGUX^XUCIGTM^ZISETUP" ;ZISETGUX^ZTBKCGUX "RTN","ZTMGRSET",140,0) D DES,MOVE "RTN","ZTMGRSET",141,0) S %S="ZOSV2GTM^ZISTCPS^ZSSGUX",%D="%ZOSV2^%ZISTCPS^%SS" "RTN","ZTMGRSET",142,0) D MOVE,ZOSF("ZOSFGUX") "RTN","ZTMGRSET",143,0) D POSTGTM "RTN","ZTMGRSET",144,0) Q "RTN","ZTMGRSET",145,0) 10 ;;NOT SUPPORTED "RTN","ZTMGRSET",146,0) Q "RTN","ZTMGRSET",147,0) MOVE ; rename % routines "RTN","ZTMGRSET",148,0) N %,X,Y "RTN","ZTMGRSET",149,0) F %=1:1:$L(%D,"^") D "RTN","ZTMGRSET",150,0) . S X=$P(%S,U,%) ; from "RTN","ZTMGRSET",151,0) . S Y=$P(%D,U,%) ; to "RTN","ZTMGRSET",152,0) . W !,"Routine: ",X "RTN","ZTMGRSET",153,0) . Q:X="" Q:Y="" I $T(^@X)="" W ?20," Missing" Q "RTN","ZTMGRSET",154,0) . X SCR Q:'$T "RTN","ZTMGRSET",155,0) . W ?20," Loaded, " "RTN","ZTMGRSET",156,0) . D COPY(X,Y) "RTN","ZTMGRSET",157,0) . W ?20,"Saved as ",Y "RTN","ZTMGRSET",158,0) Q "RTN","ZTMGRSET",159,0) ; "RTN","ZTMGRSET",160,0) COPY(FROM,TO) ; "RTN","ZTMGRSET",161,0) I ZTOS'=7,ZTOS'=8 X "ZL @FROM ZS @TO" Q "RTN","ZTMGRSET",162,0) ;For GT.M below "RTN","ZTMGRSET",163,0) N PATH,COPY S PATH=$$R "RTN","ZTMGRSET",164,0) D SILENT^%RSEL(FROM) S FROM=PATH_FROM_".m" "RTN","ZTMGRSET",165,0) S TO=PATH_$TR(TO,"%","_")_".m" "RTN","ZTMGRSET",166,0) S COPY=$S(ZTOS=7:"COPY",1:"cp") "RTN","ZTMGRSET",167,0) ZSYSTEM COPY_" "_FROM_" "_TO "RTN","ZTMGRSET",168,0) ZLINK TO "RTN","ZTMGRSET",169,0) Q "RTN","ZTMGRSET",170,0) ; "RTN","ZTMGRSET",171,0) R() ; routine directory for GT.M "RTN","ZTMGRSET",172,0) I ZTOS=7 Q $P($ZRO,",") "RTN","ZTMGRSET",173,0) I ZTOS=8 Q $$RTNDIR^ZOSVGUX "RTN","ZTMGRSET",174,0) E Q "" "RTN","ZTMGRSET",175,0) ; "RTN","ZTMGRSET",176,0) DES S %D="%ZOSV^%ZTBKC1^%ZIS4^%ZISF^%ZISH^%XUCI^ZISETUP" Q "RTN","ZTMGRSET",177,0) ; "RTN","ZTMGRSET",178,0) GLOBALS ;Set node zero of file #3.05 & #3.07 "RTN","ZTMGRSET",179,0) W !!,"Now, I will check your % globals." "RTN","ZTMGRSET",180,0) W ".........." "RTN","ZTMGRSET",181,0) F %="^%ZIS","^%ZISL","^%ZTER","^%ZUA" S:'$D(@%) @%="" "RTN","ZTMGRSET",182,0) S:$D(^%ZTSK(0))[0 ^%ZTSK(-1)=100,^%ZTSCH="" "RTN","ZTMGRSET",183,0) S Z1=$G(^%ZTSK(-1),-1),Z2=$G(^%ZTSK(0)) "RTN","ZTMGRSET",184,0) I Z1'=$P(Z2,"^",3) S:Z1'>0 ^%ZTSK(-1)=+Z2 S ^%ZTSK(0)="TASK'S^14.4^"_^%ZTSK(-1) "RTN","ZTMGRSET",185,0) S:$D(^%ZUA(3.05,0))[0 ^%ZUA(3.05,0)="FAILED ACCESS ATTEMPTS LOG^3.05^^" "RTN","ZTMGRSET",186,0) S:$D(^%ZUA(3.07,0))[0 ^%ZUA(3.07,0)="PROGRAMMER MODE LOG^3.07^^" "RTN","ZTMGRSET",187,0) Q "RTN","ZTMGRSET",188,0) NAME ;Setup the static names for this system "RTN","ZTMGRSET",189,0) MGR W !,"NAME OF MANAGER'S UCI,VOLUME SET: "_^%ZOSF("MGR")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G MGR:0[Y S ^%ZOSF("MGR")=X "RTN","ZTMGRSET",190,0) PROD W !,"PRODUCTION (SIGN-ON) UCI,VOLUME SET: "_^%ZOSF("PROD")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G PROD:0[Y S ^%ZOSF("PROD")=X "RTN","ZTMGRSET",191,0) VOL W !,"NAME OF VOLUME SET: "_^%ZOSF("VOL")_"//" R X:$S($G(DTIME):DTIME,1:9999) I X]"" S:X?3U ^%ZOSF("VOL")=X I X'?3U W "MUST BE 3 Upper case." G VOL "RTN","ZTMGRSET",192,0) W ! Q "RTN","ZTMGRSET",193,0) POSTGTM ;postinit for GTM "RTN","ZTMGRSET",194,0) S ZTOS=8 "RTN","ZTMGRSET",195,0) F ROU="ZSTART","ZSTOP" D "RTN","ZTMGRSET",196,0) .S ZSTRT=$T(@(U_ROU)) "RTN","ZTMGRSET",197,0) .I ZSTRT="" D BMES^XPDUTL("You do not currently have a "_ROU_" routine") "RTN","ZTMGRSET",198,0) .I ZSTRT'="" D BMES^XPDUTL(ZSTRT),BMES^XPDUTL("This is your current "_ROU) "RTN","ZTMGRSET",199,0) .D BMES^XPDUTL("Do you wish to save "_ROU_"GUX as "_ROU) S %=2 D YN^DICN "RTN","ZTMGRSET",200,0) .I %=1 D COPY(ROU_"GUX",ROU) "RTN","ZUGTM") 0^8^B10012519 "RTN","ZUGTM",1,0) ZU ;SF/JLI,RWF MSC/JDS,JKT- For GT.M, TIE ALL TERMINALS TO THIS ROUTINE!! ;25JUN2009 "RTN","ZUGTM",2,0) ;;8.0;KERNEL;**275,MSC**;Jul 10, 1995 "RTN","ZUGTM",3,0) ; for GT.M for VMS & Unix, version 4.3 "RTN","ZUGTM",4,0) ; "RTN","ZUGTM",5,0) ;The env var ZINTRRUPT should be set to catch all interrupts. "RTN","ZUGTM",6,0) EN ;See that escape processing is off, Conflict with Screenman "RTN","ZUGTM",7,0) U $P:(NOCENABLE:NOESCAPE) "RTN","ZUGTM",8,0) D:+$G(^%ZTSCH("LOGRSRC")) LOGRSRC^%ZOSV("$LOGIN$") "RTN","ZUGTM",9,0) N $ESTACK,$ETRAP S $ETRAP="D ERR^ZU Q:$QUIT -9 Q" "RTN","ZUGTM",10,0) S $ZINTERRUPT="I $$JOBEXAM^ZU($ZPOSITION)" "RTN","ZUGTM",11,0) D COUNT^XUSCNT(1) "RTN","ZUGTM",12,0) G ^XUS "RTN","ZUGTM",13,0) ; "RTN","ZUGTM",14,0) G ;Entry point for GUI device. "RTN","ZUGTM",15,0) Q "RTN","ZUGTM",16,0) ; "RTN","ZUGTM",17,0) ERR ;Come here on error "RTN","ZUGTM",18,0) ; handle stack overflow errors specially "RTN","ZUGTM",19,0) I $P($ZS,",",3)["STACKOFLOW" S $ET="Q:$ST>"_($ST-8)_" D ERR2^ZU" Q "RTN","ZUGTM",20,0) ; "RTN","ZUGTM",21,0) ERR2 S $ETRAP="D UNWIND^ZU" L U $P:NOCENABLE "RTN","ZUGTM",22,0) ; "RTN","ZUGTM",23,0) Q:$ECODE["" "RTN","ZUGTM",24,0) I $P($ZS,",",2,3)["^XUS1A:2, %GTM-E-IOWRITERR" G HALT "RTN","ZUGTM",25,0) ; "RTN","ZUGTM",26,0) I $G(IO)]"",$D(IO(1,IO)),$E($G(IOST))="P" D "RTN","ZUGTM",27,0) . U IO "RTN","ZUGTM",28,0) . W @$S($D(IOF):IOF,1:"#") "RTN","ZUGTM",29,0) I $G(IO(0))]"" D "RTN","ZUGTM",30,0) . U IO(0) "RTN","ZUGTM",31,0) . W !!,"RECORDING THAT AN ERROR OCCURRED ---" "RTN","ZUGTM",32,0) . W !!?15,"Sorry 'bout that" "RTN","ZUGTM",33,0) . W !,*7 "RTN","ZUGTM",34,0) . W !?10,"$STACK=",$STACK," $ECODE=",$ECODE "RTN","ZUGTM",35,0) . W !?10,"$ZSTATUS=",$ZSTATUS "RTN","ZUGTM",36,0) ; "RTN","ZUGTM",37,0) D ^%ZTER K %ZT S XUERF="" ; Capture symbol table first! "RTN","ZUGTM",38,0) ; "RTN","ZUGTM",39,0) I $G(DUZ)'>0 G HALT "RTN","ZUGTM",40,0) ; "RTN","ZUGTM",41,0) CTRLC I $D(IO)=11 U IO(0) C:IO'=IO(0) IO S IO=IO(0) "RTN","ZUGTM",42,0) W:$P($ZS,",",3)["-CTRLC" !,"--Interrupt Acknowledged",! "RTN","ZUGTM",43,0) D KILL1^XUSCLEAN ;Clean up symbol table "RTN","ZUGTM",44,0) S $ECODE=",<>," "RTN","ZUGTM",45,0) Q "RTN","ZUGTM",46,0) ; "RTN","ZUGTM",47,0) UNWIND ;Unwind the stack "RTN","ZUGTM",48,0) Q:$ESTACK>1 G CONT:$ECODE["<>",CTRLC2:$ECODE["<>" "RTN","ZUGTM",49,0) S $ECODE="" "RTN","ZUGTM",50,0) Q "RTN","ZUGTM",51,0) ; "RTN","ZUGTM",52,0) CTRLC2 S $ECODE="" G:$G(^XUTL("XQ",$J,"T"))<2 ^XUSCLEAN "RTN","ZUGTM",53,0) S ^XUTL("XQ",$J,"T")=1,XQY=$G(^(1)),XQY0=$P(XQY,"^",2,99) "RTN","ZUGTM",54,0) G:$P(XQY0,"^",4)'="M" CTRLC2 "RTN","ZUGTM",55,0) S XQPSM=$P(XQY,"^",1),XQY=+XQPSM,XQPSM=$P(XQPSM,XQY,2,3) "RTN","ZUGTM",56,0) G:'XQY ^XUSCLEAN "RTN","ZUGTM",57,0) S $ECODE="",$ETRAP="D ERR^ZU Q:$QUIT 0 Q" "RTN","ZUGTM",58,0) U $P:NOESCAPE G M1^XQ "RTN","ZUGTM",59,0) ; "RTN","ZUGTM",60,0) HALT I $D(^XUTL("XQ",$J)) D:$G(DUZ)>0 BYE^XUSCLEAN "RTN","ZUGTM",61,0) D COUNT^XUSCNT(-1) "RTN","ZUGTM",62,0) I '$ESTACK G CONT "RTN","ZUGTM",63,0) S $ETRAP="D UNWIND^ZU" ;Set new trap "RTN","ZUGTM",64,0) S $ECODE=",<>," ;Cause error to unwind stack "RTN","ZUGTM",65,0) D:+$G(^%ZTSCH("LOGRSRC")) LOGRSRC^%ZOSV("$LOGOUT$") "RTN","ZUGTM",66,0) Q "RTN","ZUGTM",67,0) CONT ; "RTN","ZUGTM",68,0) S $ECODE="",$ETRAP="" "RTN","ZUGTM",69,0) D:+$G(^%ZTSCH("LOGRSRC")) LOGRSRC^%ZOSV("$LOGOUT$") "RTN","ZUGTM",70,0) I $D(XQXFLG("HALT")) HALT "RTN","ZUGTM",71,0) I ($PRINCIPAL["_TNA") HALT ;Check for TelNet "RTN","ZUGTM",72,0) S X="Waiting "_($J#1000000) D SETENV^%ZOSV ;Change VMS name "RTN","ZUGTM",73,0) ;For sites that want to retain the connection, uncomment the next line "RTN","ZUGTM",74,0) ;U $P:NOCENABLE R !,"Enter return to continue: ",X:600 S:'$T X="^" G:X'="^" ^ZU "RTN","ZUGTM",75,0) HALT "RTN","ZUGTM",76,0) ; "RTN","ZUGTM",77,0) JOBEXAM(%ZPOS) ; "RTN","ZUGTM",78,0) N %reference S %reference=$REFERENCE "RTN","ZUGTM",79,0) S ^XUTL("XUSYS",$J,0)=$H,^XUTL("XUSYS",$J,"INTERRUPT")=$G(%ZPOS) "RTN","ZUGTM",80,0) K ^XUTL("XUSYS",$J,"JE") "RTN","ZUGTM",81,0) I $G(^XUTL("XUSYS","COMMAND"))'="EXAM" ZSHOW "SD":^XUTL("XUSYS",$J,"JE") "RTN","ZUGTM",82,0) I $G(^XUTL("XUSYS","COMMAND"))="EXAM" ZSHOW "*":^XUTL("XUSYS",$J,"JE") "RTN","ZUGTM",83,0) I $G(^XUTL("XUSYS",$J,"CMD"))="HALT" ;To do. "RTN","ZUGTM",84,0) S ^TMP("MSCZJOB",$J,0)=$H "RTN","ZUGTM",85,0) ZSHOW "*":^TMP("MSCZJOB",$J) "RTN","ZUGTM",86,0) Q 1 "RTN","ZUGTM",87,0) ; "VER") 8.0^22.0 **END** **END**