KIDS Distribution saved on Apr 01, 2011@14:39:28 RA*5.0*47 **KIDS**:RA*5.0*47^ **INSTALL NAME** RA*5.0*47 "BLD",5395,0) RA*5.0*47^RADIOLOGY/NUCLEAR MEDICINE^0^3110401^y "BLD",5395,1,0) ^^2^2^3070717^^ "BLD",5395,1,1,0) Please refer to the patch description in FORUM regarding the installation "BLD",5395,1,2,0) of RA*5.0*47. "BLD",5395,4,0) ^9.64PA^74^3 "BLD",5395,4,70,0) 70 "BLD",5395,4,70,2,0) ^9.641^70.02^2 "BLD",5395,4,70,2,70.02,0) REGISTERED EXAMS (sub-file) "BLD",5395,4,70,2,70.02,1,0) ^9.6411^.01^1 "BLD",5395,4,70,2,70.02,1,.01,0) EXAM DATE "BLD",5395,4,70,2,70.03,0) EXAMINATIONS (sub-file) "BLD",5395,4,70,2,70.03,1,0) ^9.6411^81^0 "BLD",5395,4,70,2,70.03,1,31,0) SITE ACCESSION NUMBER "BLD",5395,4,70,2,70.03,1,81,0) STUDY INSTANCE UID "BLD",5395,4,70,222) y^n^p^^^^n^^n "BLD",5395,4,70,224) "BLD",5395,4,74,0) 74 "BLD",5395,4,74,2,0) ^9.641^74.05^2 "BLD",5395,4,74,2,74,0) RAD/NUC MED REPORTS (File-top level) "BLD",5395,4,74,2,74,1,0) ^9.6411^.01^1 "BLD",5395,4,74,2,74,1,.01,0) DAY-CASE# "BLD",5395,4,74,2,74.05,0) OTHER CASE# (sub-file) "BLD",5395,4,74,2,74.05,1,0) ^9.6411^.01^1 "BLD",5395,4,74,2,74.05,1,.01,0) OTHER CASE# "BLD",5395,4,74,222) y^y^p^^^^n^^n "BLD",5395,4,74,224) "BLD",5395,4,79,0) 79 "BLD",5395,4,79,2,0) ^9.641^79^1 "BLD",5395,4,79,2,79,0) RAD/NUC MED DIVISION (File-top level) "BLD",5395,4,79,2,79,1,0) ^9.6411^.131^1 "BLD",5395,4,79,2,79,1,.131,0) USE SITE ACCESSION NUMBER? "BLD",5395,4,79,222) y^y^p^^^^n^^n "BLD",5395,4,79,224) "BLD",5395,4,"APDD",70,70.02) "BLD",5395,4,"APDD",70,70.02,.01) "BLD",5395,4,"APDD",70,70.03) "BLD",5395,4,"APDD",70,70.03,31) "BLD",5395,4,"APDD",70,70.03,81) "BLD",5395,4,"APDD",74,74) "BLD",5395,4,"APDD",74,74,.01) "BLD",5395,4,"APDD",74,74.05) "BLD",5395,4,"APDD",74,74.05,.01) "BLD",5395,4,"APDD",79,79) "BLD",5395,4,"APDD",79,79,.131) "BLD",5395,4,"B",70,70) "BLD",5395,4,"B",74,74) "BLD",5395,4,"B",79,79) "BLD",5395,6.3) 21 "BLD",5395,"ABPKG") n "BLD",5395,"INIT") EN^RA47PST "BLD",5395,"KRN",0) ^9.67PA^8989.52^19 "BLD",5395,"KRN",.4,0) .4 "BLD",5395,"KRN",.4,"NM",0) ^9.68A^3^3 "BLD",5395,"KRN",.4,"NM",1,0) RA ALL UNPRINTED REPORTS FILE #74.4^74.4^0 "BLD",5395,"KRN",.4,"NM",2,0) RA UNPRINTED REPORTS FILE #74.4^74.4^0 "BLD",5395,"KRN",.4,"NM",3,0) RA PRINTED REPORTS FILE #74.4^74.4^0 "BLD",5395,"KRN",.4,"NM","B","RA ALL UNPRINTED REPORTS FILE #74.4",1) "BLD",5395,"KRN",.4,"NM","B","RA PRINTED REPORTS FILE #74.4",3) "BLD",5395,"KRN",.4,"NM","B","RA UNPRINTED REPORTS FILE #74.4",2) "BLD",5395,"KRN",.401,0) .401 "BLD",5395,"KRN",.401,"NM",0) ^9.68A^^ "BLD",5395,"KRN",.402,0) .402 "BLD",5395,"KRN",.402,"NM",0) ^9.68A^1^1 "BLD",5395,"KRN",.402,"NM",1,0) RA REGISTER FILE #70^70^0 "BLD",5395,"KRN",.402,"NM","B","RA REGISTER FILE #70",1) "BLD",5395,"KRN",.403,0) .403 "BLD",5395,"KRN",.5,0) .5 "BLD",5395,"KRN",.84,0) .84 "BLD",5395,"KRN",3.6,0) 3.6 "BLD",5395,"KRN",3.8,0) 3.8 "BLD",5395,"KRN",9.2,0) 9.2 "BLD",5395,"KRN",9.8,0) 9.8 "BLD",5395,"KRN",9.8,"NM",0) ^9.68A^75^61 "BLD",5395,"KRN",9.8,"NM",2,0) RAHLRU^^0^B44912236 "BLD",5395,"KRN",9.8,"NM",6,0) RAHLRPT1^^0^B48303444 "BLD",5395,"KRN",9.8,"NM",8,0) RAHLRPT2^^0^B7037276 "BLD",5395,"KRN",9.8,"NM",11,0) RAHLACK^^0^B10346213 "BLD",5395,"KRN",9.8,"NM",12,0) RAHLR1^^0^B24833741 "BLD",5395,"KRN",9.8,"NM",13,0) RAHLR1A^^0^B53486094 "BLD",5395,"KRN",9.8,"NM",14,0) RAHLRU1^^0^B76146976 "BLD",5395,"KRN",9.8,"NM",15,0) RAAPI^^0^B13582847 "BLD",5395,"KRN",9.8,"NM",16,0) RA47PST^^0^B2113178 "BLD",5395,"KRN",9.8,"NM",17,0) RAHLTCPX^^0^B93748547 "BLD",5395,"KRN",9.8,"NM",21,0) RASYS^^0^B37308956 "BLD",5395,"KRN",9.8,"NM",23,0) RAHLEXF^^0^B22623264 "BLD",5395,"KRN",9.8,"NM",24,0) RABTCH^^0^B22491328 "BLD",5395,"KRN",9.8,"NM",25,0) RABTCH1^^0^B11297029 "BLD",5395,"KRN",9.8,"NM",26,0) RACNLU^^0^B35984519 "BLD",5395,"KRN",9.8,"NM",27,0) RADD2^^0^B18850431 "BLD",5395,"KRN",9.8,"NM",28,0) RADEM1^^0^B25958437 "BLD",5395,"KRN",9.8,"NM",29,0) RADLQ1^^0^B33800278 "BLD",5395,"KRN",9.8,"NM",30,0) RADLQ2^^0^B16418030 "BLD",5395,"KRN",9.8,"NM",31,0) RADLQ3^^0^B23869496 "BLD",5395,"KRN",9.8,"NM",32,0) RADLY^^0^B30113114 "BLD",5395,"KRN",9.8,"NM",33,0) RADLY1^^0^B34932703 "BLD",5395,"KRN",9.8,"NM",34,0) RAEDPT^^0^B10329969 "BLD",5395,"KRN",9.8,"NM",35,0) RAESO^^0^B27993971 "BLD",5395,"KRN",9.8,"NM",36,0) RAFLH^^0^B23566413 "BLD",5395,"KRN",9.8,"NM",37,0) RAFLH2^^0^B4606601 "BLD",5395,"KRN",9.8,"NM",38,0) RAJAC^^0^B8745582 "BLD",5395,"KRN",9.8,"NM",39,0) RANMUSE2^^0^B42611600 "BLD",5395,"KRN",9.8,"NM",40,0) RANMUSE3^^0^B17130788 "BLD",5395,"KRN",9.8,"NM",42,0) RAORD61^^0^B7128704 "BLD",5395,"KRN",9.8,"NM",43,0) RAPRINT1^^0^B29745884 "BLD",5395,"KRN",9.8,"NM",44,0) RAPROD^^0^B45447427 "BLD",5395,"KRN",9.8,"NM",45,0) RAPROS^^0^B29816651 "BLD",5395,"KRN",9.8,"NM",46,0) RAPTLU^^0^B37279557 "BLD",5395,"KRN",9.8,"NM",47,0) RAREG^^0^B43601921 "BLD",5395,"KRN",9.8,"NM",48,0) RART1^^0^B63511305 "BLD",5395,"KRN",9.8,"NM",49,0) RART2^^0^B9326949 "BLD",5395,"KRN",9.8,"NM",50,0) RARTE^^0^B44678185 "BLD",5395,"KRN",9.8,"NM",51,0) RARTE3^^0^B5378644 "BLD",5395,"KRN",9.8,"NM",52,0) RARTE5^^0^B102640298 "BLD",5395,"KRN",9.8,"NM",53,0) RARTE6^^0^B140134431 "BLD",5395,"KRN",9.8,"NM",54,0) RARTR3^^0^B28579692 "BLD",5395,"KRN",9.8,"NM",55,0) RARTST2A^^0^B25475148 "BLD",5395,"KRN",9.8,"NM",56,0) RARTUVR3^^0^B35802159 "BLD",5395,"KRN",9.8,"NM",57,0) RASTEXT^^0^B34738271 "BLD",5395,"KRN",9.8,"NM",58,0) RAUTL1^^0^B56859744 "BLD",5395,"KRN",9.8,"NM",59,0) RAUTL15^^0^B20281413 "BLD",5395,"KRN",9.8,"NM",60,0) RAUTL2^^0^B40821700 "BLD",5395,"KRN",9.8,"NM",61,0) RAUTL20^^0^B34736490 "BLD",5395,"KRN",9.8,"NM",62,0) RAUTL3^^0^B11997585 "BLD",5395,"KRN",9.8,"NM",64,0) RAHLO1^^0^B66582328 "BLD",5395,"KRN",9.8,"NM",65,0) RARTE2^^0^B32141462 "BLD",5395,"KRN",9.8,"NM",66,0) RAHLRS1^^0^B62793760 "BLD",5395,"KRN",9.8,"NM",68,0) RAPM^^0^B73229634 "BLD",5395,"KRN",9.8,"NM",69,0) RAPM2^^0^B96765436 "BLD",5395,"KRN",9.8,"NM",70,0) RAPMW2^^0^B79947106 "BLD",5395,"KRN",9.8,"NM",71,0) RAHLO3^^0^B23427355 "BLD",5395,"KRN",9.8,"NM",72,0) RAMAG03C^^0^B28078514 "BLD",5395,"KRN",9.8,"NM",73,0) RARTE1^^0^B66239828 "BLD",5395,"KRN",9.8,"NM",74,0) RARTE4^^0^B25063198 "BLD",5395,"KRN",9.8,"NM",75,0) RARIC^^0^B25901329 "BLD",5395,"KRN",9.8,"NM","B","RA47PST",16) "BLD",5395,"KRN",9.8,"NM","B","RAAPI",15) "BLD",5395,"KRN",9.8,"NM","B","RABTCH",24) "BLD",5395,"KRN",9.8,"NM","B","RABTCH1",25) "BLD",5395,"KRN",9.8,"NM","B","RACNLU",26) "BLD",5395,"KRN",9.8,"NM","B","RADD2",27) "BLD",5395,"KRN",9.8,"NM","B","RADEM1",28) "BLD",5395,"KRN",9.8,"NM","B","RADLQ1",29) "BLD",5395,"KRN",9.8,"NM","B","RADLQ2",30) "BLD",5395,"KRN",9.8,"NM","B","RADLQ3",31) "BLD",5395,"KRN",9.8,"NM","B","RADLY",32) "BLD",5395,"KRN",9.8,"NM","B","RADLY1",33) "BLD",5395,"KRN",9.8,"NM","B","RAEDPT",34) "BLD",5395,"KRN",9.8,"NM","B","RAESO",35) "BLD",5395,"KRN",9.8,"NM","B","RAFLH",36) "BLD",5395,"KRN",9.8,"NM","B","RAFLH2",37) "BLD",5395,"KRN",9.8,"NM","B","RAHLACK",11) "BLD",5395,"KRN",9.8,"NM","B","RAHLEXF",23) "BLD",5395,"KRN",9.8,"NM","B","RAHLO1",64) "BLD",5395,"KRN",9.8,"NM","B","RAHLO3",71) "BLD",5395,"KRN",9.8,"NM","B","RAHLR1",12) "BLD",5395,"KRN",9.8,"NM","B","RAHLR1A",13) "BLD",5395,"KRN",9.8,"NM","B","RAHLRPT1",6) "BLD",5395,"KRN",9.8,"NM","B","RAHLRPT2",8) "BLD",5395,"KRN",9.8,"NM","B","RAHLRS1",66) "BLD",5395,"KRN",9.8,"NM","B","RAHLRU",2) "BLD",5395,"KRN",9.8,"NM","B","RAHLRU1",14) "BLD",5395,"KRN",9.8,"NM","B","RAHLTCPX",17) "BLD",5395,"KRN",9.8,"NM","B","RAJAC",38) "BLD",5395,"KRN",9.8,"NM","B","RAMAG03C",72) "BLD",5395,"KRN",9.8,"NM","B","RANMUSE2",39) "BLD",5395,"KRN",9.8,"NM","B","RANMUSE3",40) "BLD",5395,"KRN",9.8,"NM","B","RAORD61",42) "BLD",5395,"KRN",9.8,"NM","B","RAPM",68) "BLD",5395,"KRN",9.8,"NM","B","RAPM2",69) "BLD",5395,"KRN",9.8,"NM","B","RAPMW2",70) "BLD",5395,"KRN",9.8,"NM","B","RAPRINT1",43) "BLD",5395,"KRN",9.8,"NM","B","RAPROD",44) "BLD",5395,"KRN",9.8,"NM","B","RAPROS",45) "BLD",5395,"KRN",9.8,"NM","B","RAPTLU",46) "BLD",5395,"KRN",9.8,"NM","B","RAREG",47) "BLD",5395,"KRN",9.8,"NM","B","RARIC",75) "BLD",5395,"KRN",9.8,"NM","B","RART1",48) "BLD",5395,"KRN",9.8,"NM","B","RART2",49) "BLD",5395,"KRN",9.8,"NM","B","RARTE",50) "BLD",5395,"KRN",9.8,"NM","B","RARTE1",73) "BLD",5395,"KRN",9.8,"NM","B","RARTE2",65) "BLD",5395,"KRN",9.8,"NM","B","RARTE3",51) "BLD",5395,"KRN",9.8,"NM","B","RARTE4",74) "BLD",5395,"KRN",9.8,"NM","B","RARTE5",52) "BLD",5395,"KRN",9.8,"NM","B","RARTE6",53) "BLD",5395,"KRN",9.8,"NM","B","RARTR3",54) "BLD",5395,"KRN",9.8,"NM","B","RARTST2A",55) "BLD",5395,"KRN",9.8,"NM","B","RARTUVR3",56) "BLD",5395,"KRN",9.8,"NM","B","RASTEXT",57) "BLD",5395,"KRN",9.8,"NM","B","RASYS",21) "BLD",5395,"KRN",9.8,"NM","B","RAUTL1",58) "BLD",5395,"KRN",9.8,"NM","B","RAUTL15",59) "BLD",5395,"KRN",9.8,"NM","B","RAUTL2",60) "BLD",5395,"KRN",9.8,"NM","B","RAUTL20",61) "BLD",5395,"KRN",9.8,"NM","B","RAUTL3",62) "BLD",5395,"KRN",19,0) 19 "BLD",5395,"KRN",19,"NM",0) ^9.68A^4^4 "BLD",5395,"KRN",19,"NM",1,0) RA SITEACCNUM^^0 "BLD",5395,"KRN",19,"NM",2,0) RA SITEMANAGER^^2 "BLD",5395,"KRN",19,"NM",3,0) RA HL7 MESSAGE RESEND^^0 "BLD",5395,"KRN",19,"NM",4,0) RA HL7 RESEND BY DATE RANGE^^0 "BLD",5395,"KRN",19,"NM","B","RA HL7 MESSAGE RESEND",3) "BLD",5395,"KRN",19,"NM","B","RA HL7 RESEND BY DATE RANGE",4) "BLD",5395,"KRN",19,"NM","B","RA SITEACCNUM",1) "BLD",5395,"KRN",19,"NM","B","RA SITEMANAGER",2) "BLD",5395,"KRN",19.1,0) 19.1 "BLD",5395,"KRN",101,0) 101 "BLD",5395,"KRN",101,"NM",0) ^9.68A^4^4 "BLD",5395,"KRN",101,"NM",1,0) RA REG 2.4^^0 "BLD",5395,"KRN",101,"NM",2,0) RA EXAMINED 2.4^^0 "BLD",5395,"KRN",101,"NM",3,0) RA CANCEL 2.4^^0 "BLD",5395,"KRN",101,"NM",4,0) RA RPT 2.4^^0 "BLD",5395,"KRN",101,"NM","B","RA CANCEL 2.4",3) "BLD",5395,"KRN",101,"NM","B","RA EXAMINED 2.4",2) "BLD",5395,"KRN",101,"NM","B","RA REG 2.4",1) "BLD",5395,"KRN",101,"NM","B","RA RPT 2.4",4) "BLD",5395,"KRN",409.61,0) 409.61 "BLD",5395,"KRN",771,0) 771 "BLD",5395,"KRN",870,0) 870 "BLD",5395,"KRN",8989.51,0) 8989.51 "BLD",5395,"KRN",8989.52,0) 8989.52 "BLD",5395,"KRN",8994,0) 8994 "BLD",5395,"KRN","B",.4,.4) "BLD",5395,"KRN","B",.401,.401) "BLD",5395,"KRN","B",.402,.402) "BLD",5395,"KRN","B",.403,.403) "BLD",5395,"KRN","B",.5,.5) "BLD",5395,"KRN","B",.84,.84) "BLD",5395,"KRN","B",3.6,3.6) "BLD",5395,"KRN","B",3.8,3.8) "BLD",5395,"KRN","B",9.2,9.2) "BLD",5395,"KRN","B",9.8,9.8) "BLD",5395,"KRN","B",19,19) "BLD",5395,"KRN","B",19.1,19.1) "BLD",5395,"KRN","B",101,101) "BLD",5395,"KRN","B",409.61,409.61) "BLD",5395,"KRN","B",771,771) "BLD",5395,"KRN","B",870,870) "BLD",5395,"KRN","B",8989.51,8989.51) "BLD",5395,"KRN","B",8989.52,8989.52) "BLD",5395,"KRN","B",8994,8994) "BLD",5395,"PRET") "BLD",5395,"QDEF") ^^^^NO^^^^YES^^YES "BLD",5395,"QUES",0) ^9.62^^0 "BLD",5395,"REQB",0) ^9.611^6^3 "BLD",5395,"REQB",4,0) RA*5.0*99^2 "BLD",5395,"REQB",5,0) RA*5.0*104^2 "BLD",5395,"REQB",6,0) RA*5.0*90^2 "BLD",5395,"REQB","B","RA*5.0*104",5) "BLD",5395,"REQB","B","RA*5.0*90",6) "BLD",5395,"REQB","B","RA*5.0*99",4) "FIA",70) RAD/NUC MED PATIENT "FIA",70,0) ^RADPT( "FIA",70,0,0) 70IP "FIA",70,0,1) y^n^p^^^^n^^n "FIA",70,0,10) "FIA",70,0,11) "FIA",70,0,"RLRO") "FIA",70,0,"VR") 5.0^RA "FIA",70,70) 1 "FIA",70,70,2) "FIA",70,70.02) 1 "FIA",70,70.02,.01) "FIA",70,70.03) 1 "FIA",70,70.03,31) "FIA",70,70.03,81) "FIA",74) RAD/NUC MED REPORTS "FIA",74,0) ^RARPT( "FIA",74,0,0) 74I "FIA",74,0,1) y^y^p^^^^n^^n "FIA",74,0,10) "FIA",74,0,11) "FIA",74,0,"RLRO") "FIA",74,0,"VR") 5.0^RA "FIA",74,74) 1 "FIA",74,74,.01) "FIA",74,74,4.5) "FIA",74,74.05) 1 "FIA",74,74.05,.01) "FIA",79) RAD/NUC MED DIVISION "FIA",79,0) ^RA(79, "FIA",79,0,0) 79P "FIA",79,0,1) y^y^p^^^^n^^n "FIA",79,0,10) "FIA",79,0,11) "FIA",79,0,"RLRO") "FIA",79,0,"VR") 5.0^RA "FIA",79,79) 1 "FIA",79,79,.131) "INIT") EN^RA47PST "IX",70,70,"ADC1",0) 70^ADC1^This cross-reference links an exam record with site specific accession number.^R^^F^IR^W^70.03^^^^^S "IX",70,70,"ADC1",.1,0) ^^2^2^3090423^ "IX",70,70,"ADC1",.1,1,0) This cross-reference provides other applications the ability to look up an "IX",70,70,"ADC1",.1,2,0) exam record based on a site specific accession number. "IX",70,70,"ADC1",1) S ^RADPT("ADC1",$E(X,1,30),DA(2),DA(1),DA)="" "IX",70,70,"ADC1",2) K ^RADPT("ADC1",$E(X,1,30),DA(2),DA(1),DA) "IX",70,70,"ADC1",2.5) K ^RADPT("ADC1") "IX",70,70,"ADC1",11.1,0) ^.114IA^1^1 "IX",70,70,"ADC1",11.1,1,0) 1^F^70.03^31^30^1^F "IX",70,70,"ASIUID",0) 70^ASIUID^Cross reference to assist API to return SIUID for exam^R^^F^IR^W^70.03^^^^^S "IX",70,70,"ASIUID",.1,0) ^^2^2^3101028^^^^ "IX",70,70,"ASIUID",.1,1,0) This is a sorting only cross-reference for use with a new API to return "IX",70,70,"ASIUID",.1,2,0) SIUID. "IX",70,70,"ASIUID",1) S ^RADPT("ASIUID",$E(X,1,240),DA(2),DA(1),DA)="" "IX",70,70,"ASIUID",2) K ^RADPT("ASIUID",$E(X,1,240),DA(2),DA(1),DA) "IX",70,70,"ASIUID",2.5) K ^RADPT("ASIUID") "IX",70,70,"ASIUID",11.1,0) ^.114IA^1^1 "IX",70,70,"ASIUID",11.1,1,0) 1^F^70.03^81^240^1^F "IX",70,70,"ASIUID",11.1,1,3) "KRN",.4,341,-1) 0^3 "KRN",.4,341,0) RA PRINTED REPORTS^3090326.1514^@^74.4^^@^3090331 "KRN",.4,341,"%D",0) ^^2^2^2940607^^ "KRN",.4,341,"%D",1,0) This print template is used to generate the List Reports in a Batch "KRN",.4,341,"%D",2,0) option. "KRN",.4,341,"DXS",1,9.2) S I(0,0)=$G(D0),DIP(1)=$S($D(^RABTCH(74.4,D0,0)):^(0),1:""),D0=$P(DIP(1),U,1) S:'D0!'$D(^RARPT(+D0,0)) D0=-1 S DIP(101)=$S($D(^RARPT(D0,0)):^(0),1:"") "KRN",.4,341,"DXS",2,9) X DXS(2,9.2) S DIP(102)=$G(X),D0=$P(DIP(101),U,2) S:'D0!'$D(^DPT(+D0,0)) D0=-1 S DIP(201)=$S($D(^DPT(D0,.36)):^(.36),1:"") S X=$P(DIP(201),U,4) S D0=I(0,0) "KRN",.4,341,"DXS",2,9.2) S I(0,0)=$G(D0),DIP(1)=$S($D(^RABTCH(74.4,D0,0)):^(0),1:""),D0=$P(DIP(1),U,1) S:'D0!'$D(^RARPT(+D0,0)) D0=-1 S I(100,0)=$G(D0),DIP(101)=$S($D(^RARPT(D0,0)):^(0),1:"") "KRN",.4,341,"DXS",3,9.2) S DIP(1)=$S($D(^RABTCH(74.4,D0,0)):^(0),1:"") S X=$P($G(^SC(+$P(DIP(1),U,8),0)),U)]"",DIP(2)=$G(X) S X=$P($G(^SC(+$P(DIP(1),U,8),0)),U),DIP(3)=$G(X) S X=1 "KRN",.4,341,"F",1) W $$FLAGMEM^RAUTL20;C1;L1;"";Z;"W $$FLAGMEM^RAUTL20"~.01;C2;"Day/Case"~ "KRN",.4,341,"F",2) X DXS(1,9.2) S X=$P($G(^DPT(+$P(DIP(101),U,2),0)),U) S D0=I(0,0) W X K DIP;C19;L16;"Patient";Z;"REPORT:PATIENT NAME"~ "KRN",.4,341,"F",3) X DXS(2,9) W X K DIP;C36;L7;"BID";Z;"REPORT:PATIENT NAME:PRIMARY SHORT ID"~ "KRN",.4,341,"F",4) W $$DATX^RARTST3($P($G(^RABTCH(74.4,D0,0)),U,4));C43;L14;"Date Printed";Z;"W $$DATX^RARTST3($P($G(^RABTCH(74.4,D0,0)),U,4))"~3;C59;L12;"Printed By"~ "KRN",.4,341,"F",5) X DXS(3,9.2) S DIP(4)=$G(X) S X=$P($G(^DIC(42,+$P(DIP(1),U,6),0)),U),X=$S(DIP(2):DIP(3),DIP(4):X) W X K DIP;C72;L9;"Ward/Clinic";Z;"$S(PRINCIPAL CLINIC]"":PRINCIPAL CLINIC,1:WARD)"~ "KRN",.4,341,"H") @ "KRN",.4,341,"SUB") 1 "KRN",.4,342,-1) 0^1 "KRN",.4,342,0) RA ALL UNPRINTED REPORTS^3090326.1459^@^74.4^^@^3090331 "KRN",.4,342,"%D",0) ^^2^2^2940607^^ "KRN",.4,342,"%D",1,0) Generates an output of reports in the distribution queue that "KRN",.4,342,"%D",2,0) have not been printed. "KRN",.4,342,"DXS",1,9.2) S I(0,0)=$G(D0),DIP(1)=$S($D(^RABTCH(74.4,D0,0)):^(0),1:""),D0=$P(DIP(1),U,1) S:'D0!'$D(^RARPT(+D0,0)) D0=-1 S DIP(101)=$S($D(^RARPT(D0,0)):^(0),1:"") "KRN",.4,342,"DXS",2,9) X DXS(2,9.2) S DIP(102)=$G(X),D0=$P(DIP(101),U,2) S:'D0!'$D(^DPT(+D0,0)) D0=-1 S DIP(201)=$S($D(^DPT(D0,.36)):^(.36),1:"") S X=$P(DIP(201),U,4) S D0=I(0,0) "KRN",.4,342,"DXS",2,9.2) S I(0,0)=$G(D0),DIP(1)=$S($D(^RABTCH(74.4,D0,0)):^(0),1:""),D0=$P(DIP(1),U,1) S:'D0!'$D(^RARPT(+D0,0)) D0=-1 S I(100,0)=$G(D0),DIP(101)=$S($D(^RARPT(D0,0)):^(0),1:"") "KRN",.4,342,"DXS",3,9.2) S DIP(1)=$S($D(^RABTCH(74.4,D0,0)):^(0),1:"") S X=$P($G(^SC(+$P(DIP(1),U,8),0)),U)]"",DIP(2)=$G(X) S X=$P($G(^SC(+$P(DIP(1),U,8),0)),U),DIP(3)=$G(X) S X=1 "KRN",.4,342,"F",1) W $$FLAGMEM^RAUTL20;C1;L1;"";Z;"W $$FLAGMEM^RAUTL20"~.01;C2;"Day/Case"~ "KRN",.4,342,"F",2) X DXS(1,9.2) S X=$P($G(^DPT(+$P(DIP(101),U,2),0)),U) S D0=I(0,0) W X K DIP;C19;L16;"Patient";Z;"REPORT:PATIENT NAME"~ "KRN",.4,342,"F",3) X DXS(2,9) W X K DIP;C36;L5;"BID";Z;"REPORT:PATIENT NAME:PRIMARY SHORT ID"~ "KRN",.4,342,"F",4) W $$DATX^RARTST3($P($G(^RARPT(+$G(^RABTCH(74.4,D0,0)),0)),U,7));C41;L14;"Date Verified";Z;"W $$DATX^RARTST3($P($G(^RARPT(+$G(^RABTCH(74.4,D0,0)),0)),U,7))"~ "KRN",.4,342,"F",5) X DXS(3,9.2) S DIP(4)=$G(X) S X=$P($G(^DIC(42,+$P(DIP(1),U,6),0)),U),X=$S(DIP(2):DIP(3),DIP(4):X) W X K DIP;C58;L9;"Ward/Clinic";Z;"$S(PRINCIPAL CLINIC]"":PRINCIPAL CLINIC,1:WARD)"~ "KRN",.4,342,"F",6) 11;C68;L12;"Routing Queue"~ "KRN",.4,342,"H") @ "KRN",.4,342,"SUB") 1 "KRN",.4,344,-1) 0^2 "KRN",.4,344,0) RA UNPRINTED REPORTS^3090326.1508^@^74.4^^@^3100903 "KRN",.4,344,"%D",0) ^^2^2^2960730^^^ "KRN",.4,344,"%D",1,0) This template is used in the generation of reports in the "KRN",.4,344,"%D",2,0) distribution queue yet to be printed. "KRN",.4,344,"DXS",1,9.2) S I(0,0)=$G(D0),DIP(1)=$S($D(^RABTCH(74.4,D0,0)):^(0),1:""),D0=$P(DIP(1),U,1) S:'D0!'$D(^RARPT(+D0,0)) D0=-1 S DIP(101)=$S($D(^RARPT(D0,0)):^(0),1:"") "KRN",.4,344,"DXS",2,9) X DXS(2,9.2) S DIP(102)=$G(X),D0=$P(DIP(101),U,2) S:'D0!'$D(^DPT(+D0,0)) D0=-1 S DIP(201)=$S($D(^DPT(D0,.36)):^(.36),1:"") S X=$P(DIP(201),U,4) S D0=I(0,0) "KRN",.4,344,"DXS",2,9.2) S I(0,0)=$G(D0),DIP(1)=$S($D(^RABTCH(74.4,D0,0)):^(0),1:""),D0=$P(DIP(1),U,1) S:'D0!'$D(^RARPT(+D0,0)) D0=-1 S I(100,0)=$G(D0),DIP(101)=$S($D(^RARPT(D0,0)):^(0),1:"") "KRN",.4,344,"DXS",3,9.2) S DIP(1)=$S($D(^RABTCH(74.4,D0,0)):^(0),1:"") S X=$P($G(^SC(+$P(DIP(1),U,8),0)),U)]"",DIP(2)=$G(X) S X=$P($G(^SC(+$P(DIP(1),U,8),0)),U),DIP(3)=$G(X) S X=1 "KRN",.4,344,"F",1) W $$FLAGMEM^RAUTL20;C1;L1;"";Z;"W $$FLAGMEM^RAUTL20"~.01;C2;"Day/Case"~ "KRN",.4,344,"F",2) X DXS(1,9.2) S X=$P($G(^DPT(+$P(DIP(101),U,2),0)),U) S D0=I(0,0) W X K DIP;C19;L15;"Patient";Z;"REPORT:PATIENT NAME"~ "KRN",.4,344,"F",3) X DXS(2,9) W X K DIP;C37;L7;"BID";Z;"REPORT:PATIENT NAME:PRIMARY SHORT ID"~ "KRN",.4,344,"F",4) W $$DATX^RARTST3($P($G(^RARPT(+$G(^RABTCH(74.4,D0,0)),0)),U,7));C46;L14;"Date Verified";Z;"W $$DATX^RARTST3($P($G(^RARPT(+$G(^RABTCH(74.4,D0,0)),0)),U,7))"~ "KRN",.4,344,"F",5) X DXS(3,9.2) S DIP(4)=$G(X) S X=$P($G(^DIC(42,+$P(DIP(1),U,6),0)),U),X=$S(DIP(2):DIP(3),DIP(4):X) W X K DIP;C64;L10;"Ward/Clinic";Z;"$S(PRINCIPAL CLINIC]"":PRINCIPAL CLINIC,1:WARD)"~ "KRN",.4,344,"H") @ "KRN",.4,344,"SUB") 1 "KRN",.402,227,-1) 0^1 "KRN",.402,227,0) RA REGISTER^3101108.1336^^70^^^3110401 "KRN",.402,227,"AR",70.03,589) 1^RACTRG11 "KRN",.402,227,"DIAB",1,2,70.03,7) 9.5//^S X=$S($D(RARSH):RARSH,1:"");REQ "KRN",.402,227,"DIAB",1,3,70.1,0) ALL "KRN",.402,227,"DIAB",2,2,70.03,9) 7;REQ "KRN",.402,227,"DIAB",4,2,70.03,7) 9//^S X=$S($D(RASHA):RASHA,1:"");REQ "KRN",.402,227,"DIAB",4,2,70.03,8) 6;REQ "KRN",.402,227,"DIAB",4,2,70.03,16) 80;REQ "KRN",.402,227,"DIAB",5,2,70.03,1) 2//^S X=$S($D(RAPRC):RAPRC,1:"");REQ "KRN",.402,227,"DIAB",8,2,70.03,9) 19;REQ "KRN",.402,227,"DIAB",9,2,70.03,7) 8//^S X=$S($D(RACLNC):RACLNC,1:"");REQ "KRN",.402,227,"DR",1,70) I '$D(RAMDV)!('$D(RAMLC))!('$D(RADTE))!('$D(RACAT))!('$D(RAOIFN))!('$D(RAIMGTY)) W !?3,$C(7),"Variables RAMDV,RAMLC,RADTE,RACAT,RAIMGTY and RAOIFN must be defined!",! S Y="@999"; "KRN",.402,227,"DR",1,70,1) W !!?3,"...will now register ",RANME," with the next case number...";2///^S X=RADTE;@999;S REM="let calling rtn kill RAPOP,RAFM,RAFM1,RAI,RAMOD,RASTI,RACMTHOD,RANMFLG,RAIEN702"; "KRN",.402,227,"DR",2,70.02) S RADTI=DA;2////^S X=$P(RAMLC,U,6);3////^S X=+RAMDIV;4////^S X=+RAMLC;Q;50///^S X=RACN; "KRN",.402,227,"DR",3,70.03) S RACN=X,RACNI=DA;S RACMTHOD=$P(^RA(79.1,+$P(RAMLC,"^"),0),"^",21);S RACMTHOD=$S(RACMTHOD]"":RACMTHOD,1:0);26////^S X=RACMTHOD;I $$USESSAN^RAHLRU1()'=1 S Y=81;31////^S X=$$ACCNUM^RAAPI($G(DA(2)),$G(DA(1)),$G(DA)); "KRN",.402,227,"DR",3,70.03,1) 81////^S X=$$SIUID^RAAPI();3////^S X=$O(^RA(72,"AA",RAIMGTY,1,0));S RASTI=X;@3;2R~//^S X=$S($D(RAPRC):RAPRC,1:"");S RAPRI=X;S RAPRI(0)=$G(^RAMIS(71,+RAPRI,0));I $P(RAMDV,U,7),($P(RAPRI(0),U,6)="B") S Y="@3000"; "KRN",.402,227,"DR",3,70.03,2) S:$P($G(^RA(79,+$$DIVSION^RAUTL6(DT,+$P($G(^RAO(75.1,+RAOIFN,0)),"^",22)),.1)),"^",7)="N"!($P(RAPRI(0),"^",6)'="B") Y="@4";@3000;W !?3,$C(7),"A 'detailed' procedure or a 'series' of procedures is required!";2///@;S Y="@3";@4; "KRN",.402,227,"DR",3,70.03,3) S RAPX(RACNI)=RACN_"^"_^RAMIS(71,RAPRI,0);S REM="don't copy proc mods for Series and Broad, 9/24/1999";S:$P(RAPX(RACNI),U,7)="S" Y="@7";S:$P(RAPX(RACNI),U,7)="B" Y="@8"; "KRN",.402,227,"DR",3,70.03,4) S RAI=0,Y=$S('$D(RAPRC):"@6",RAPRC'=$P(RAPX(RACNI),U,2):"@6",1:"@5");@5;S RAI=$O(^RAO(75.1,+RAOIFN,"M","B",RAI)) S:'RAI Y="@6";S RAMOD=$S($D(^RAMIS(71.2,RAI,0)):$P(^(0),U),1:-1) S:RAMOD<0 Y="@6"; "KRN",.402,227,"DR",3,70.03,5) S:'$D(^RAMIS(71.2,"AB",+$$ITYPE^RASITE(+$G(RAPRI)),RAI)) Y="@5";125///^S X=RAMOD;S Y="@5";@6;125;^4.01;@7;D:$T(SETDEFS^RACPTMSC)]"" SETDEFS^RACPTMSC;S REM="don't ask cpt mods after stuffing";@8;11////^S X=RAOIFN; "KRN",.402,227,"DR",3,70.03,6) 14////^S X=$S($D(RAPIFN):RAPIFN,1:"");18////^S X=$S($P(RAPX(RACNI),U,15)]"":$P(RAPX(RACNI),U,15),1:"");@20;4//^S X=RACAT;S RAX=$E(X),Y=$S(RAX="I":"@60",RAX="E":"@45",RAX="R":"@30","CS"[RAX:"@40",1:"@50") K RAX;@30; "KRN",.402,227,"DR",3,70.03,7) 9.5R~//^S X=$S($D(RARSH):RARSH,1:"");S Y=$S($D(RAWARD):"@60",1:"@50");@40;9R~//^S X=$S($D(RASHA):RASHA,1:"");S Y="@100";@45;S:$D(RAWARD) Y="@60";@50;8R~//^S X=$S($D(RACLNC):RACLNC,1:"");S RACLNC=$P(^SC(X,0),U);S Y="@100";@60; "KRN",.402,227,"DR",3,70.03,8) S:'$D(RAWARD) RAWARD="Unknown" S:'$D(RASER) RASER="Unknown" S:'$D(RABED) RABED="Unknown";W !?5,"Ward: ",RAWARD," Service: ",RASER," Bedsection: ",RABED;I RAWARD'="Unknown" S Y="@66";6R~;S Y="@68";@66;6///^S X=RAWARD;@68; "KRN",.402,227,"DR",3,70.03,9) I RASER'="Unknown" S Y="@80";7R~;S Y="@85";@80;7///^S X=RASER;@85;I RABED'="Unknown" S Y="@95";19R~;S Y="@100";@95;19///^S X=RABED;@100;21////^S X=$S($D(RARDTE):RARDTE,1:"");22////^S X=$S($D(RALIFN):RALIFN,1:""); "KRN",.402,227,"DR",3,70.03,10) I '$D(^RAMIS(71,RAPRI,"F",0)) S Y="@300";S RAI=0;@200;S RAI=$O(^RAMIS(71,RAPRI,"F",RAI)) S:RAI'>0!('$D(^(+RAI,0))) Y="@300"; "KRN",.402,227,"DR",3,70.03,11) S RAFM(1)=+^RAMIS(71,RAPRI,"F",RAI,0),RAFM1=+$P(^(0),U,2),RAFM=$S($D(^RA(78.4,RAFM(1),0)):$P(^(0),U),1:-1),RAFM=$S('$D(^("I")):RAFM,'^("I"):RAFM,1:-1) S:RAFM<0 Y="@200";50///^S X=RAFM;S Y="@200";@300; "KRN",.402,227,"DR",3,70.03,12) S RAPOP=0 D USER^RAUTL S:RAPOP Y="@999";S:'$P(RAMDV,U,10) Y="@350";75///^S X="""NOW""";@350;S RANMFLG=0;S:'$D(RAIMGTYI) RAIMGTYI=$O(^RA(79.2,"B",RAIMGTY,0));S:$P($G(^RA(79.2,+$G(RAIMGTYI),0)),"^",5)="Y" RANMFLG=1; "KRN",.402,227,"DR",3,70.03,13) S:'RANMFLG Y="@450";S:'$O(^RAMIS(71,RAPRI,"NUC",0)) Y="@450";S REM="is this proc's ASK RADIOPHARMACEUTICAL = NEVER ?";S:$P(^RAMIS(71,RAPRI,0),U,2)=1 Y="@450";S REM="en1^ranmpt1 will stuff default radiopharms during registration"; "KRN",.402,227,"DR",3,70.03,14) S RAIEN702=$$EN1^RANMPT1(RADFN,RADTE,RACN);S:RAIEN702=-1 Y="@450";500////^S X=RAIEN702;@450;S:'$O(^RAMIS(71,RAPRI,"P",0)) Y="@700";S REM="en2^ranmpt1 will stuff default meds";D EN2^RANMPT1(RADFN,RADTI,RACNI);@700; "KRN",.402,227,"DR",3,70.03,15) 100///^S X="""NOW""";S RACOM="ask pregnant question if appropriate otherwise branch to @8001" K RACOM;S Y=$$ASKPREG^RAUTL8();W !," PREGNANT AT TIME OF ORDER ENTRY: ",$$GET1^DIQ(75.1,$G(RAOIFN)_",",13); "KRN",.402,227,"DR",3,70.03,16) S:$D(RAOPT("ADDEXAM")) Y="@8001";32;S:($$PRSCR^RAUTL8(RADFN,RADTI,RACNI,"I")="n")!($$PRSCR^RAUTL8(RADFN,RADTI,RACNI,"I")="") Y="@8001";80R~;@8001; "KRN",.402,227,"DR",4,70.04) 2///^S X=RAFM1; "KRN",.402,227,"DR",4,70.05) 2////^S X=RASTI;3////^S X=RADUZ; "KRN",.402,227,"DR",4,70.07) 2///^S X="E";3////^S X=RADUZ;S RATCXX=$$GETTCOM^RAUTL11(RADFN,RADTI,RACNI);4//^S X=RATCXX;S:RATCXX'=X Y="@18";4///@;K ^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",DA,"TCOM");@18;K RATCXX S RAFIN=""; "KRN",.402,227,"DR",4,70.1) .01 "KRN",.402,227,"DR",4.01,70.1) .01; "KRN",.402,227,"ROU") ^RACTRG "KRN",.402,227,"ROUOLD") RACTRG "KRN",19,1710,-1) 2^2 "KRN",19,1710,0) RA SITEMANAGER^IRM Menu^^M^50^^^^^^^ "KRN",19,1710,10,0) ^19.01IP^14^12 "KRN",19,1710,10,14,0) 12879^^99 "KRN",19,1710,10,14,"^") RA SITEACCNUM "KRN",19,1710,"U") IRM MENU "KRN",19,11174,-1) 0^3 "KRN",19,11174,0) RA HL7 MESSAGE RESEND^Resend Radiology HL7 Message^^R^^RA MGR^^^^^y^RADIOLOGY/NUCLEAR MEDICINE^^1^1 "KRN",19,11174,1,0) ^19.06^2^2^3100128^^^^ "KRN",19,11174,1,1,0) This option can be used to resend HL7 messages to all subscribers for "KRN",19,11174,1,2,0) selected cases. "KRN",19,11174,15) K RAOPT("RESEND") "KRN",19,11174,20) S RAOPT("RESEND")="" "KRN",19,11174,25) RAHLRS "KRN",19,11174,"U") RESEND RADIOLOGY HL7 MESSAGE "KRN",19,12559,-1) 0^4 "KRN",19,12559,0) RA HL7 RESEND BY DATE RANGE^Resend Radiology HL7 Messages By Date Range^^R^^RA MGR^^^^^y^RADIOLOGY/NUCLEAR MEDICINE^^1^1 "KRN",19,12559,1,0) ^19.06^2^2^3100128^^^^ "KRN",19,12559,1,1,0) This option can be used to resend HL7 messages to selected subscribers by "KRN",19,12559,1,2,0) date range. "KRN",19,12559,15) K RAOPT("RESEND DT") "KRN",19,12559,20) S RAOPT("RESEND DT")="" "KRN",19,12559,25) RAHLRS1 "KRN",19,12559,668000,0) ^19.0668^1^1 "KRN",19,12559,668000,1,0) RSD "KRN",19,12559,"U") RESEND RADIOLOGY HL7 MESSAGES "KRN",19,12879,-1) 0^1 "KRN",19,12879,0) RA SITEACCNUM^Site Accession Number Set-up^^R^^^^^^^^ "KRN",19,12879,1,0) ^19.06^2^2^3100128^^^^ "KRN",19,12879,1,1,0) This option is used to turn on use of the Site (long) Accession Number "KRN",19,12879,1,2,0) when registering new cases in the Radiology/Nuc Med package. "KRN",19,12879,25) SACNPAR^RASYS "KRN",19,12879,"U") SITE ACCESSION NUMBER SET-UP "KRN",101,5790,-1) 0^1 "KRN",101,5790,0) RA REG 2.4^Rad/Nuc Med exam registered (v2.4 HL7)^^E^^^^^^^^RADIOLOGY/NUCLEAR MEDICINE "KRN",101,5790,1,0) ^101.06^8^8^3080331^^^^ "KRN",101,5790,1,1,0) This protocol is triggered whenever a Radiology/Nuclear Medicine exam "KRN",101,5790,1,2,0) is registered. It executes code that creates an HL7 ORM message "KRN",101,5790,1,3,0) consisting of PID, PV1, ORC, OBR, OBX and ZDS segments. The message "KRN",101,5790,1,4,0) contains all relevant information about the exam, including procedure, "KRN",101,5790,1,5,0) time of registration, procedure modifiers, CPT modifiers, patient "KRN",101,5790,1,6,0) allergies, and clinical history. "KRN",101,5790,1,7,0) "KRN",101,5790,1,8,0) This protocol is used to trigger v2.4 compliant HL7 messages. "KRN",101,5790,99) 60422,47960 "KRN",101,5790,770) RA-VOICE-SERVER^^ORM^O01^^^^^^2.4^ "KRN",101,5790,772) D MAIN^RAHLACK "KRN",101,5790,775,0) ^101.0775PA^^0 "KRN",101,5791,-1) 0^2 "KRN",101,5791,0) RA EXAMINED 2.4^Rad/Nuc Med examined case (v2.4 HL7)^^E^^^^^^^^RADIOLOGY/NUCLEAR MEDICINE "KRN",101,5791,1,0) ^101.06^8^8^3080212^^ "KRN",101,5791,1,1,0) This protocol is triggered whenever a Radiology/Nuclear Medicine exam "KRN",101,5791,1,2,0) has been edited by the user. It executes code that creates an HL7 ORM "KRN",101,5791,1,3,0) message consisting of PID, PV1, ORC, OBR, OBX and ZDS segments. This "KRN",101,5791,1,4,0) message contains all relevant information about the exam, including "KRN",101,5791,1,5,0) procedure, time of registration, procedure modifiers, CPT modifiers, "KRN",101,5791,1,6,0) patient allergies, and clinical history. "KRN",101,5791,1,7,0) "KRN",101,5791,1,8,0) This protocol is used to trigger v2.4 compliant HL7 messages. "KRN",101,5791,99) 60422,48019 "KRN",101,5791,770) RA-VOICE-SERVER^^ORM^O01^^^^^^2.4^ "KRN",101,5791,772) D MAIN^RAHLACK "KRN",101,5791,775,0) ^101.0775PA^^0 "KRN",101,5792,-1) 0^3 "KRN",101,5792,0) RA CANCEL 2.4^Rad/Nuc Med exam cancellation (v2.4 HL7)^^E^^^^^^^^RADIOLOGY/NUCLEAR MEDICINE "KRN",101,5792,1,0) ^101.06^8^8^3080212^^^ "KRN",101,5792,1,1,0) This protocol is triggered whenever a Radiology/Nuclear Medicine exam is "KRN",101,5792,1,2,0) cancelled. It executes code that creates an HL7 ORM message consisting "KRN",101,5792,1,3,0) of PID, PV1, ORC, OBR, OBX and ZDS segments. The message contains all "KRN",101,5792,1,4,0) relevant information about the exam, including procedure, time of "KRN",101,5792,1,5,0) cancellation, procedure modifiers, CPT modifiers, patient allergies and "KRN",101,5792,1,6,0) clinical history. "KRN",101,5792,1,7,0) "KRN",101,5792,1,8,0) This protocol is used to trigger v2.4 compliant HL7 messages. "KRN",101,5792,99) 60422,48054 "KRN",101,5792,770) RA-VOICE-SERVER^^ORM^O01^^^^^^2.4^ "KRN",101,5792,772) D MAIN^RAHLACK "KRN",101,5792,775,0) ^101.0775PA^^0 "KRN",101,5793,-1) 0^4 "KRN",101,5793,0) RA RPT 2.4^Rad/Nuc Med report released/verified (v2.4 HL7)^^E^^^^^^^^RADIOLOGY/NUCLEAR MEDICINE "KRN",101,5793,1,0) ^101.06^8^8^3080212^^ "KRN",101,5793,1,1,0) This protocol is triggered whenever a Radiology/Nuclear Medicine report "KRN",101,5793,1,2,0) enters into a status of Verified or Released/Not Verified. It executes "KRN",101,5793,1,3,0) code that creates an HL7 ORU message consisting of PID, OBR and OBX "KRN",101,5793,1,4,0) segments. The message contains relevant information about the report, "KRN",101,5793,1,5,0) including procedure, procedure modifiers, diagnostic code, interpreting "KRN",101,5793,1,6,0) physician, impression text and report text. "KRN",101,5793,1,7,0) "KRN",101,5793,1,8,0) This protocol is used to trigger v2.4 compliant HL7 messages. "KRN",101,5793,99) 60422,48086 "KRN",101,5793,770) RA-VOICE-SERVER^^ORU^R01^^^^^^2.4^ "KRN",101,5793,772) D MAIN^RAHLACK "KRN",101,5793,775,0) ^101.0775PA^^0 "MBREQ") 0 "ORD",5,.4) .4;5;;;EDEOUT^DIFROMSO(.4,DA,"",XPDA);FPRE^DIFROMSI(.4,"",XPDA);EPRE^DIFROMSI(.4,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.4,DA,"",XPDA);DEL^DIFROMSK(.4,"",%) "ORD",5,.4,0) PRINT TEMPLATE "ORD",7,.402) .402;7;;;EDEOUT^DIFROMSO(.402,DA,"",XPDA);FPRE^DIFROMSI(.402,"",XPDA);EPRE^DIFROMSI(.402,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.402,DA,"",XPDA);DEL^DIFROMSK(.402,"",%) "ORD",7,.402,0) INPUT TEMPLATE "ORD",15,101) 101;15;;;PRO^XPDTA;PROF1^XPDIA;PROE1^XPDIA;PROF2^XPDIA;;PRODEL^XPDIA "ORD",15,101,0) PROTOCOL "ORD",18,19) 19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA "ORD",18,19,0) OPTION "PKG",18,-1) 1^1 "PKG",18,0) RADIOLOGY/NUCLEAR MEDICINE^RA^REGISTERS PATIENTS,RECORDS EXAMS,PROFILES,AMIS REPORTS "PKG",18,20,0) ^9.402P^^ "PKG",18,22,0) ^9.49I^1^1 "PKG",18,22,1,0) 5.0^3051109^2980407^50 "PKG",18,22,1,"PAH",1,0) 47^3110401^1866 "PKG",18,22,1,"PAH",1,1,0) ^^2^2^3110401 "PKG",18,22,1,"PAH",1,1,1,0) Please refer to the patch description in FORUM regarding the installation "PKG",18,22,1,"PAH",1,1,2,0) of RA*5.0*47. "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") YES "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") YES "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") 61 "RTN","RA47PST") 0^16^B2113178 "RTN","RA47PST",1,0) RA47PST ;Hines OI/GJC - Post-init Driver, patch 47 ;04/17/07 11:30 "RTN","RA47PST",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21 "RTN","RA47PST",3,0) ; "RTN","RA47PST",4,0) VERSION Q "RTN","RA47PST",5,0) ; "RTN","RA47PST",6,0) EN ; entry point for the post-install logic "RTN","RA47PST",7,0) ; make sure the [RA REGISTER] (RACTRG*) input template is "RTN","RA47PST",8,0) ; re-compiled so user workflow is not interrupted. "RTN","RA47PST",9,0) ; "RTN","RA47PST",10,0) ; Integration Agreements utilized in this software "RTN","RA47PST",11,0) ; "RTN","RA47PST",12,0) ; tag routine number usage custodian "RTN","RA47PST",13,0) ; -------------------------------------------------- "RTN","RA47PST",14,0) ; EN DIEZ 10002 supported VA FileMan "RTN","RA47PST",15,0) ; BMES XPDUTL 10141 supported KERNEL "RTN","RA47PST",16,0) ; FIND DIC 2051 supported VA FileMan "RTN","RA47PST",17,0) ; ROUSIZE DILF 2649 supported VA FileMan "RTN","RA47PST",18,0) ; "RTN","RA47PST",19,0) ; RADMAX=maximum routine size (bytes) for this system "RTN","RA47PST",20,0) ; RACTNAM=compiled input template name (fixed to input template) "RTN","RA47PST",21,0) ; RAINPERR=error flag - default value is zero (no error condition) "RTN","RA47PST",22,0) ; a value of one if: the input template lookup failed or "RTN","RA47PST",23,0) ; expected compiled input template name is not associated "RTN","RA47PST",24,0) ; with the proper input template "RTN","RA47PST",25,0) ; RAINP70=local array where input template specific data is stored "RTN","RA47PST",26,0) ; RAINPNME=name on the input template to be compiled RA REGISTER "RTN","RA47PST",27,0) ; "RTN","RA47PST",28,0) N X,Y,DMAX S RADMAX=$$ROUSIZE^DILF "RTN","RA47PST",29,0) ; "RTN","RA47PST",30,0) ;input template RA REGISTER compiles routines in the namespace: RACTRG* "RTN","RA47PST",31,0) ; "RTN","RA47PST",32,0) S RACTNAM="RACTRG",RAINPNME="RA REGISTER" "RTN","RA47PST",33,0) ; "RTN","RA47PST",34,0) D FIND^DIC(.402,"","","O",RAINPNME,"","","","","RAINP70","") "RTN","RA47PST",35,0) ; "RTN","RA47PST",36,0) ;If the input template record is missing quit but check the other input "RTN","RA47PST",37,0) ;template. "RTN","RA47PST",38,0) ; "RTN","RA47PST",39,0) I $G(RAINP70("DILIST",2,1))'>0 S RAINPERR=$$ERROR(RAINPNME) D XIT Q "RTN","RA47PST",40,0) ; "RTN","RA47PST",41,0) ;compile the input templates... "RTN","RA47PST",42,0) ; "RTN","RA47PST",43,0) ;DMAX: maximum routine size "RTN","RA47PST",44,0) ; X: the name of the routine for the compiled input template; i.e. "RTN","RA47PST",45,0) ; RACTRG "RTN","RA47PST",46,0) ; Y: the IEN of the input template to be compiled "RTN","RA47PST",47,0) S DMAX=RADMAX,X=RACTNAM,Y=$G(RAINP70("DILIST",2,1)) "RTN","RA47PST",48,0) D EN^DIEZ "RTN","RA47PST",49,0) ; "RTN","RA47PST",50,0) XIT ;clean up symbol table and exit "RTN","RA47PST",51,0) K RACTNAM,RADMAX,RAINP70,RAINPERR,RAINPNME "RTN","RA47PST",52,0) Q "RTN","RA47PST",53,0) ; "RTN","RA47PST",54,0) ERROR(N) ;This function set the error flag & records the error "RTN","RA47PST",55,0) K RATXT S RATXT(1)="'"_N_"' was not found in the INPUT TEMPLATE (#.402) file." "RTN","RA47PST",56,0) S RATXT(2)=" " D BMES^XPDUTL(.RATXT) K RATXT "RTN","RA47PST",57,0) Q 1 "RTN","RA47PST",58,0) ; "RTN","RAAPI") 0^15^B13582847 "RTN","RAAPI",1,0) RAAPI ;HISC/GJC,RTK - API & function utilities ;04/16/07 15:02 "RTN","RAAPI",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21 "RTN","RAAPI",3,0) ; "RTN","RAAPI",4,0) ;Integration Agreements "RTN","RAAPI",5,0) ;---------------------- "RTN","RAAPI",6,0) ;$$NS^XUAF4(2171); $$KSP^XUPARAM(2541) "RTN","RAAPI",7,0) ; "RTN","RAAPI",8,0) ACCNUM(RADFN,RADTI,RACNI) ; return the site specific accession number "RTN","RAAPI",9,0) ;internal use for the VistA Radiology application "RTN","RAAPI",10,0) ; "RTN","RAAPI",11,0) ;input : RADFN=the DFN of the patient record in the PATIENT (#2) file "RTN","RAAPI",12,0) ; RADTI=inverse date/time of the exam "RTN","RAAPI",13,0) ; RACNI=the IEN of the case level record "RTN","RAAPI",14,0) ;return: sss-mmddyy-case# (site specific accession number) "RTN","RAAPI",15,0) ; "RTN","RAAPI",16,0) I RADFN=""!(RADTI="")!(RACNI="") Q "" ;all MUST be defined "RTN","RAAPI",17,0) N RAC,RAD,RAE S RAE=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) ;exam node "RTN","RAAPI",18,0) S RAC=9999999.9999-RADTI ;RAC=FM internal date/time "RTN","RAAPI",19,0) S RAD=$E(RAC,4,7)_$E(RAC,2,3)_"-"_+RAE ;mmddyy-case# "RTN","RAAPI",20,0) Q $E($P($$NS^XUAF4($$KSP^XUPARAM("INST")),U,2),1,3)_"-"_RAD "RTN","RAAPI",21,0) ; "RTN","RAAPI",22,0) ACCFIND(Y,RAA) ; "RTN","RAAPI",23,0) ; "RTN","RAAPI",24,0) ;input : Y=the accession number in either a 'sss-mmddyy-xxxxx' or "RTN","RAAPI",25,0) ; 'mmddyy-xxxxx' format "RTN","RAAPI",26,0) ; : RAA(n)=the array used to return the data in the following "RTN","RAAPI",27,0) ; format RADFN_^_RADTI_^_RACNI "RTN","RAAPI",28,0) ; "RTN","RAAPI",29,0) ;return: n>0 successful, else n<0... 'n' is the number of array "RTN","RAAPI",30,0) ; elements when successful. When unsuccessful (n<0) 'n' is "RTN","RAAPI",31,0) ; a specific error dialog which is returned along with the "RTN","RAAPI",32,0) ; invalid accession number. "RTN","RAAPI",33,0) ; "RTN","RAAPI",34,0) ; Examples: "RTN","RAAPI",35,0) ; -1^"invalid site accession number format"^accession # "RTN","RAAPI",36,0) ; -2^"invalid accession number format"^accession # "RTN","RAAPI",37,0) ; -3^"no data associated with this accession number"^accession # "RTN","RAAPI",38,0) ; "RTN","RAAPI",39,0) I $L(Y,"-")=3 Q:Y'?3N1"-"6N1"-"1.5N "-1^invalid site accession number format^"_Y "RTN","RAAPI",40,0) I $L(Y,"-")=2 Q:Y'?6N1"-"1.5N "-2^invalid accession number format^"_Y "RTN","RAAPI",41,0) N X S X=$S($L(Y,"-")=3:$NA(^RADPT("ADC1")),1:$NA(^RADPT("ADC"))) "RTN","RAAPI",42,0) Q:$O(@X@(Y,0))'>0 "-3^no data associated with this accession number^"_Y "RTN","RAAPI",43,0) N RADFN,RADTI,RACNI,Z S:$D(U)#2=0 U="^" "RTN","RAAPI",44,0) S (RADFN,Z)=0 F S RADFN=$O(@X@(Y,RADFN)) Q:'RADFN D "RTN","RAAPI",45,0) .S RADTI=0 F S RADTI=$O(@X@(Y,RADFN,RADTI)) Q:'RADTI D "RTN","RAAPI",46,0) ..S RACNI=0 F S RACNI=$O(@X@(Y,RADFN,RADTI,RACNI)) Q:'RACNI D "RTN","RAAPI",47,0) ...S Z=Z+1,RAA(Z)=RADFN_U_RADTI_U_RACNI "RTN","RAAPI",48,0) ...Q "RTN","RAAPI",49,0) ..Q "RTN","RAAPI",50,0) .Q "RTN","RAAPI",51,0) Q Z ;success "RTN","RAAPI",52,0) ; "RTN","RAAPI",53,0) ACCRPT(Y,RAA) ;return accession number(s) given file #74 pointer value - RTK "RTN","RAAPI",54,0) ; "RTN","RAAPI",55,0) ;input : Y=pointer to a record in file #74 "RTN","RAAPI",56,0) ; : RAA(n)=the array used to return the data. "RTN","RAAPI",57,0) ; "RTN","RAAPI",58,0) ;return: n>0 successful, n<0 unsuccessful "RTN","RAAPI",59,0) ; "RTN","RAAPI",60,0) ; When successful, 'n' is the number of array elements. "RTN","RAAPI",61,0) ; If n=1 the single accession number is returned in RAA(1) "RTN","RAAPI",62,0) ; If n>1, the "lead" accession number (for printsets) is "RTN","RAAPI",63,0) ; returned in RAA(1) and subsequent ones are returned in "RTN","RAAPI",64,0) ; RAA(2) thru RAA(n) "RTN","RAAPI",65,0) ; Accession numbers are returned in either "mmddyy-case#" or "RTN","RAAPI",66,0) ; "sss-mmddyy-case#" format "RTN","RAAPI",67,0) ; When unsuccessful, n<0, an error message is "RTN","RAAPI",68,0) ; returned along with the invalid file #74 pointer value. "RTN","RAAPI",69,0) ; "RTN","RAAPI",70,0) K RAA N RADCN,RAOTHCS,RARPTIEN,Z S RARPTIEN=Y "RTN","RAAPI",71,0) I '$D(^RARPT(Y,0)) Q "-1^invalid file #74 pointer value^"_Y "RTN","RAAPI",72,0) S RADCN=$P($G(^RARPT(RARPTIEN,0)),U,1) ;day-case # "RTN","RAAPI",73,0) S Z=1,RAA(Z)=RADCN "RTN","RAAPI",74,0) F RAOTHCS=0:0 S RAOTHCS=$O(^RARPT(RARPTIEN,1,RAOTHCS)) Q:RAOTHCS'>0 D "RTN","RAAPI",75,0) .S Z=Z+1,RAA(Z)=$P($G(^RARPT(RARPTIEN,1,RAOTHCS,0)),U,1) "RTN","RAAPI",76,0) Q Z "RTN","RAAPI",77,0) ; "RTN","RAAPI",78,0) SIUID() ; called from [RA REGISTER] template, creates the STUDY INSTANCE UID "RTN","RAAPI",79,0) ; also called directly from RAMAG03C for exams created thru the importer "RTN","RAAPI",80,0) ; RADFN, RADTI and RACNI are set in RA REGISTER template/RAMAG03C "RTN","RAAPI",81,0) N RASSAN,RASIUID S RASIUID="" "RTN","RAAPI",82,0) ; if SSAN exists use it to build RASIUID "RTN","RAAPI",83,0) S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RAAPI",84,0) I RASSAN'="" S RASIUID=$$STUDYUID^MAGDRAHL(RADTI,RACNI,RASSAN) Q RASIUID "RTN","RAAPI",85,0) ; else if RASSAN="" do the lines below to use the legacy acc # "RTN","RAAPI",86,0) N RAC,RAD,RAE S RAE=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) ;exam node "RTN","RAAPI",87,0) S RAC=9999999.9999-RADTI ;RAC=FM internal date/time "RTN","RAAPI",88,0) S RAD=$E(RAC,4,7)_$E(RAC,2,3)_"-"_+RAE ;mmddyy-case# "RTN","RAAPI",89,0) S RASIUID=$$STUDYUID^MAGDRAHL(RADTI,RACNI,RAD) "RTN","RAAPI",90,0) Q RASIUID "RTN","RAAPI",91,0) ; "RTN","RAAPI",92,0) GETSIUID(RADFN,RADTI,RACNI) ; return the value of the exam's SIUID "RTN","RAAPI",93,0) Q $G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SIUID")) "RTN","RAAPI",94,0) ; "RTN","RAAPI",95,0) SIUIDFND(Y,RAA) ; return exam data for a given study instance UID "RTN","RAAPI",96,0) ;input : Y=the study instance UID "RTN","RAAPI",97,0) ; : RAA(1)=variable to hold the data in the following format: "RTN","RAAPI",98,0) ; RADFN_^_RADTI_^_RACNI "RTN","RAAPI",99,0) ; "RTN","RAAPI",100,0) ;return: n=1 if successful, else n<-1 with error message "RTN","RAAPI",101,0) ; When successful, n=1 and RAA(1) is returned in above format "RTN","RAAPI",102,0) ; When unsuccessful 'n' is a specific error dialog "RTN","RAAPI",103,0) ; which is returned along with the invalid study instance UID: "RTN","RAAPI",104,0) ; -1^"no data associated with this study instance UID"^siuid "RTN","RAAPI",105,0) ; "RTN","RAAPI",106,0) K RAA N RADFN,RADTI,RACNI S RASIUID=Y,Z=0 "RTN","RAAPI",107,0) S RADFN=0 F S RADFN=$O(^RADPT("ASIUID",RASIUID,RADFN)) Q:'RADFN D "RTN","RAAPI",108,0) .S RADTI=0 F S RADTI=$O(^RADPT("ASIUID",RASIUID,RADFN,RADTI)) Q:'RADTI D "RTN","RAAPI",109,0) ..S RACNI=0 F S RACNI=$O(^RADPT("ASIUID",RASIUID,RADFN,RADTI,RACNI)) Q:'RACNI D "RTN","RAAPI",110,0) ...S Z=Z+1,RAA(Z)=RADFN_"^"_RADTI_"^"_RACNI "RTN","RAAPI",111,0) I Z=0 Q "-1^no data associated with this study instance UID^"_RASIUID "RTN","RAAPI",112,0) Q Z "RTN","RABTCH") 0^24^B22491328 "RTN","RABTCH",1,0) RABTCH ;HISC/CAH,FPT AISC/MJK,RMO-Batch Report Menu ;3/1/96 13:18 "RTN","RABTCH",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21 "RTN","RABTCH",3,0) 1 ;;Select a Batch "RTN","RABTCH",4,0) W ! K RABTCH S DIC("S")="I $P(^(0),U,3)=DUZ,'$P(^(0),U,4)",DIC("DR")="2///NOW;3////"_DUZ,DIC("A")="Select Batch: ",DIC="^RABTCH(74.2,",DIC(0)="AEZLQ",DLAYGO=74.2 "RTN","RABTCH",5,0) D ^DIC G Q1:Y<0 S RABTCH=+Y,RABTCHN=$P(Y,"^",2) "RTN","RABTCH",6,0) Q1 K %,%DT,C,D0,DA,DDH,DI,DIC,DIE,DLAYGO,DQ,DR,I,POP,X,Y Q "RTN","RABTCH",7,0) ; "RTN","RABTCH",8,0) 2 ;;List Batch Entries "RTN","RABTCH",9,0) F RAPEAT=0:0 W ! Q:$G(RAX)["^" S DIC("A")="Select Batch: ",DIC="^RABTCH(74.2,",DIC(0)="AEZMQ" D ^DIC K DIC Q:Y<1 S RABTCH=+Y,ZTRTN="START2^RABTCH",ZTSAVE("RABTCH")="" W ! D ZIS^RAUTL I 'RAPOP D START2 "RTN","RABTCH",10,0) K RAPEAT,RAPOP,RAX D Q2 "RTN","RABTCH",11,0) Q "RTN","RABTCH",12,0) START2 ; start report processing "RTN","RABTCH",13,0) U IO S Y(0)=$G(^RABTCH(74.2,RABTCH,0)),RAPGE=0,RAX="" "RTN","RABTCH",14,0) N RA1 D HDR2 "RTN","RABTCH",15,0) F I=0:0 S I=$O(^RABTCH(74.2,RABTCH,"R",I)) Q:I'>0!(RAX["^") I $D(^(I,0)) S RARPT=^(0),RAFL=$S($P(RARPT,"^",2)="Y":"*",1:""),RARPT=+RARPT I $D(^RARPT(RARPT,0)) S RA0=^(0),RA1=$O(^(1,"B",0)) D "RTN","RABTCH",16,0) .I $Y>(IOSL-4) D:$E(IOST)="C" CRCHK^RAORD6 D:$D(ZTQUEUED) STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAX="^" Q:RAX["^" D HDR2 "RTN","RABTCH",17,0) .S RACN=$P(RA0,"^",4),RADTI=9999999.9999-$P(RA0,"^",3),RADFN=+$P(RA0,"^",2) "RTN","RABTCH",18,0) .I $L($P(RA0,U,1))>12 S RACNI=$O(^RADPT("ADC1",$P(RA0,U,1),RADFN,RADTI,0)) "RTN","RABTCH",19,0) .I $L($P(RA0,U,1))'>12 S RACNI=$O(^RADPT("ADC",$P(RA0,U,1),RADFN,RADTI,0)) "RTN","RABTCH",20,0) .N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RABTCH",21,0) .S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN) "RTN","RABTCH",22,0) .I $$USESSAN^RAHLRU1() W !?1,RAFL,?2,RACNDSP W:RA1]"" "+" S Y=$P($P(RA0,"^",3),".") D D^RAUTL W ?22,Y,?35,$S($D(^DPT(RADFN,0)):$E($P(^(0),"^"),1,29),1:"Unknown") "RTN","RABTCH",23,0) .I '$$USESSAN^RAHLRU1() W !?2,RAFL,?3,$J(RACN,4) W:RA1]"" " +" S Y=$P($P(RA0,"^",3),".") D D^RAUTL W ?15,Y,?30,$S($D(^DPT(RADFN,0)):$E($P(^(0),"^"),1,29),1:"Unknown") "RTN","RABTCH",24,0) .S Z="" I $D(^RADPT(RADFN,"DT",RADTI,"P","B",RACN)),$O(^(RACN,0))>0,$D(^RADPT(RADFN,"DT",RADTI,"P",$O(^(0)),0)) S Z=^(0) "RTN","RABTCH",25,0) .W ?60,$E($S($D(^VA(200,+$P(Z,"^",12),0)):$P(^(0),"^"),$D(^VA(200,+$P(Z,"^",15),0)):$P(^(0),"^"),1:"Unknown"),1,19) "RTN","RABTCH",26,0) Q2 K %,DIC,I,RA0,RABTCH,RACN,RADFN,RADTI,RAFL,RAPGE,RARPT,X,Y,Z,ZTQUEUED,ZTSTOP "RTN","RABTCH",27,0) K C,DDH,I,POP,DISYS "RTN","RABTCH",28,0) D CLOSE^RAUTL "RTN","RABTCH",29,0) Q "RTN","RABTCH",30,0) ; "RTN","RABTCH",31,0) HDR2 ; report header "RTN","RABTCH",32,0) S RAPGE=RAPGE+1 "RTN","RABTCH",33,0) W:$Y>0 @IOF "RTN","RABTCH",34,0) W !,"Batch: ",$P(Y(0),"^"),?30,"Date Created: " S Y=$P(Y(0),"^",2) D D^RAUTL W Y,?65,$S($D(^VA(200,+$P(Y(0),"^",3),0)):$E($P(^(0),"^"),1,14),1:"") "RTN","RABTCH",35,0) S Y=$P(Y(0),"^",4) D D^RAUTL:Y]"" W !?30,"Last Printed: ",Y,!!,"* indicates the report has been printed from batch",! "RTN","RABTCH",36,0) W $$REPEAT^XLFSTR("=",79) "RTN","RABTCH",37,0) I $$USESSAN^RAHLRU1() W !!?1,"Case No.",?22,"Exam Date",?35,"Patient",?60,"Interpreting Phys." "RTN","RABTCH",38,0) I $$USESSAN^RAHLRU1() W !?1,"----------------",?22,"-----------",?35,"--------------------",?60,"------------------" "RTN","RABTCH",39,0) I '$$USESSAN^RAHLRU1() W !!?1,"Case No.",?15,"Exam Date",?30,"Patient",?60,"Interpreting Phys." "RTN","RABTCH",40,0) I '$$USESSAN^RAHLRU1() W !?1,"--------",?15,"---------",?30,"-------",?60,"------------------" "RTN","RABTCH",41,0) Q "RTN","RABTCH",42,0) 3 ;;Print a Batch "RTN","RABTCH",43,0) ;SET^RAPSET1 is called so that RAMLC is defined and the default print "RTN","RABTCH",44,0) ;device for report printing can be determined "RTN","RABTCH",45,0) D SET^RAPSET1 I $D(XQUIT) K XQUIT Q "RTN","RABTCH",46,0) W ! S DIC("A")="Select Batch: ",DIC="^RABTCH(74.2,",DIC(0)="AEZMQ" D ^DIC K DIC G Q3:Y<0 S RABTCH=+Y "RTN","RABTCH",47,0) W !!,"Batch: ",$P(Y(0),"^"),?30,"Date Created: " S Y=$P(Y(0),"^",2) D D^RAUTL W Y,?65,$S($D(^VA(200,+$P(Y(0),"^",3),0)):$E($P(^(0),"^"),1,14),1:"") "RTN","RABTCH",48,0) S Y=$P(Y(0),"^",4) D D^RAUTL:Y]"" W !?30,"Last Printed: ",Y "RTN","RABTCH",49,0) ASKPRT R !!,"Are you sure? No// ",X:DTIME S:'$T!(X="")!(X["^") X="N" G Q3:"Nn"[$E(X) I "Yy"'[$E(X) W:X'["?" *7 W !!?3,"Enter 'YES' to print this batch, or 'NO' not to." G ASKPRT "RTN","RABTCH",50,0) BTCH S ION=$P(RAMLC,"^",10),IOP=$S(ION]"":"Q;"_ION,1:"Q") "RTN","RABTCH",51,0) S DIE="^RABTCH(74.2,",DA=RABTCH,DR="4///^S X=""NOW""" D ^DIE "RTN","RABTCH",52,0) S ZTRTN="START^RABTCH",ZTSAVE("RABTCH")="" "RTN","RABTCH",53,0) W ! D ZIS^RAUTL G Q3:RAPOP "RTN","RABTCH",54,0) START U IO S U="^",RABT=RABTCH "RTN","RABTCH",55,0) S X="T",%DT="" D ^%DT S DT=Y "RTN","RABTCH",56,0) F RABTI=0:0 S RABTI=$O(^RABTCH(74.2,RABT,"R",RABTI)) Q:RABTI'>0 I $D(^(RABTI,0)) S RABTCH=RABT,RARPT=+^(0),^(0)=RARPT_"^Y" D PRT^RARTR "RTN","RABTCH",57,0) Q3 K C,D0,DA,DIE,DR,J,K,RABT,RABTI,RADTI,RACN,RADTE,RADFN,RARPT,RABTCH,W,RAPOP "RTN","RABTCH",58,0) K %W,%X,%Y1,D,DI,DIC,DQ,X,Y "RTN","RABTCH",59,0) K DDH,DISYS,I,POP "RTN","RABTCH",60,0) W ! D CLOSE^RAUTL Q "RTN","RABTCH",61,0) ; "RTN","RABTCH",62,0) 4 ;;Remove/Add a Report from a Batch "RTN","RABTCH",63,0) W ! S DIC("S")="I $P(^(0),U,3)=DUZ",DIC("A")="Select Batch: ",DIC="^RABTCH(74.2,",DIC(0)="AEZMQ" D ^DIC K DIC G Q4:Y<0 S DA=+Y "RTN","RABTCH",64,0) S DIE="^RABTCH(74.2,",DR="25",DR(2,74.21)=".01" D ^DIE "RTN","RABTCH",65,0) Q4 K %,%Y,C,D0,DA,DIE,DR,J,K,RABT,RABTI,RADTI,RACN,RADTE,RADFN,RARPT,RABTCH,W "RTN","RABTCH",66,0) K D,D1,DDH,DI,DIC,DIZ,DLAYGO,DQ,I,X "RTN","RABTCH",67,0) K DDC,DST,DISYS,POP "RTN","RABTCH",68,0) Q "RTN","RABTCH1") 0^25^B11297029 "RTN","RABTCH1",1,0) RABTCH1 ;HISC/CAH,FPT AISC/MJK,RMO-Batch Report Menu ;9/28/94 10:49 "RTN","RABTCH1",2,0) ;;5.0;Radiology/Nuclear Medicine;**8,47**;Mar 16, 1998;Build 21 "RTN","RABTCH1",3,0) VERIFY ;Verify Batch "RTN","RABTCH1",4,0) D SET^RAPSET1 I $D(XQUIT) K XQUIT Q "RTN","RABTCH1",5,0) W ! S DIC("S")="I $P(^(0),U,4)",DIC("A")="Select Batch: ",DIC="^RABTCH(74.2,",DIC(0)="AEZMQ" D ^DIC K DIC G Q:Y<0 S RAPGM="NXT^RABTCH1",RABTCH=+Y,LINE="",$P(LINE,"-",80)="" "RTN","RABTCH1",6,0) W !!,"Batch: ",$P(Y(0),"^"),?30,"Date Created: " S Y=$P(Y(0),"^",2) D D^RAUTL W Y,?65,$S($D(^VA(200,+$P(Y(0),"^",3),0)):$E($P(^(0),"^"),1,14),1:"") "RTN","RABTCH1",7,0) S Y=$P(Y(0),"^",4) D D^RAUTL:Y]"" W !?30,"Last Printed: ",Y "RTN","RABTCH1",8,0) ASKVER R !!,"Is this the batch you want to verify? No// ",X:DTIME S:'$T!(X="")!(X["^") X="N" G Q:"Nn"[$E(X) I "Yy"'[$E(X) W:X'["?" *7 W !!,?3,"Enter 'YES' to verify this batch, or 'NO' not to." G ASKVER "RTN","RABTCH1",9,0) ; Get e-sig "RTN","RABTCH1",10,0) D ^RASIGU I %=0 G Q "RTN","RABTCH1",11,0) S RAVER=$P(^VA(200,RASIG("PER"),0),U,1) "RTN","RABTCH1",12,0) S RAONLINE="" "RTN","RABTCH1",13,0) ; "RTN","RABTCH1",14,0) W !,LINE F RAI=0:0 S RAI=$O(^RABTCH(74.2,RABTCH,"R",RAI)) Q:RAI'>0 I $D(^(RAI,0)) S (RARPT,Y)=+^(0) D RASET^RAUTL2 D CHK:+Y Q:$D(RAUP)!('$D(RACT)) "RTN","RABTCH1",15,0) G:'$D(RACT) Q1 "RTN","RABTCH1",16,0) ASKBAT R !!,"Can this batch now be deleted? No// ",X:DTIME S:'$T!(X="")!(X["^") X="N" G Q1:"Nn"[$E(X) I "Yy"'[$E(X) W:X'["?" *7 W !!?3,"Enter 'YES' to delete this batch, or 'NO' not to." G ASKBAT "RTN","RABTCH1",17,0) S DA=RABTCH,DIK="^RABTCH(74.2," D ^DIK W !?3,"...deletion complete." "RTN","RABTCH1",18,0) Q1 I '$D(RAUP),$D(^TMP($J,"RA","DT")) D UPSTATM^RAUTL0 "RTN","RABTCH1",19,0) Q K %,%X,D,D0,D1,DA,DIC,DIK,DIE,DR,RA,RACT,RADATE,RAUP,RABTCH,LINE,RADFN,RADTE,RADTI,RACN,RACNI,RAOR,RARPT,RA0,RAI,RAPGM,RASN,RASTI,RAVER,^TMP($J,"RA") "RTN","RABTCH1",20,0) K %W,%X,%Y1,C,X,Y "RTN","RABTCH1",21,0) K DDH,DISYS,POP "RTN","RABTCH1",22,0) K RAVER,RAONLINE,RASIG "RTN","RABTCH1",23,0) Q "RTN","RABTCH1",24,0) ; "RTN","RABTCH1",25,0) CHK N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RABTCH1",26,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN) "RTN","RABTCH1",27,0) I $$USESSAN^RAHLRU1() I $P(^RARPT(RARPT,0),"^",5)="V" W !?3,"...report for case no. ",RACNDSP," is already verified" S RACT="" W !,LINE Q "RTN","RABTCH1",28,0) I $$USESSAN^RAHLRU1() W !,"Report for case no. ",RACNDSP," for ",$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"UNKNOWN") G 31^RART "RTN","RABTCH1",29,0) I '$$USESSAN^RAHLRU1() I $P(^RARPT(RARPT,0),"^",5)="V" W !?3,"...report for case no. ",RACN," is already verified" S RACT="" W !,LINE Q "RTN","RABTCH1",30,0) I '$$USESSAN^RAHLRU1() W !,"Report for case no. ",RACN," for ",$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"UNKNOWN") G 31^RART "RTN","RABTCH1",31,0) NXT I '$D(RACT) K RAAB Q "RTN","RABTCH1",32,0) W !,LINE I RACT="V" S ^TMP($J,"RA","DT",RADTE,RARPT)=$S($D(RAAB):1,1:"") "RTN","RABTCH1",33,0) K RAAB Q "RTN","RACNLU") 0^26^B35984519 "RTN","RACNLU",1,0) RACNLU ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Case Number Lookup ;11/13/00 09:13 "RTN","RACNLU",2,0) ;;5.0;Radiology/Nuclear Medicine;**7,15,23,47**;Mar 16, 1998;Build 21 "RTN","RACNLU",3,0) CASE N RADIV,RAIMAGE,RANODE "RTN","RACNLU",4,0) R !!,"Enter Case Number: ",X:DTIME S:'$T!(X="") X="^" G Q:X="^" "RTN","RACNLU",5,0) I X?1A W !?3,*7,"You must enter more than one character of the name!" G CASE "RTN","RACNLU",6,0) I X?1A.AP!(X?1A4N)!(X?9N) S RAHEAD="**** Case Lookup by Patient ****",DIC(0)="EMQ" D ^RADPA G CASE:Y<0 S RADFN=+Y G ^RAPTLU "RTN","RACNLU",7,0) I X?16.N.E D QUES G CASE "RTN","RACNLU",8,0) D SPACE:X=" " G Q:X="^" D QUES:'X&(X'="??") G CASE:X="^" D SEL G CASE:"^"[X!('RACNT) F I=1:1:11 S @$P("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",I)=$P(Y,"^",I) "RTN","RACNLU",9,0) W:RACNT'=1 !!?1,"Case No.: ",RACN,?16,"Procedure: ",$E(RAPRC,1,30),?58,"Name: ",$E(RANME,1,20) "RTN","RACNLU",10,0) I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S ^DISV($S($D(DUZ)#2:DUZ,1:0),"RA","CASE #")=RADFN_"^"_RADTI_"^"_RACNI,Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) "RTN","RACNLU",11,0) Q K I,RACNT,RADTCN,RAEND,RAFL,RAFST,RAIX,^TMP("MAG",$J,"COL"),^TMP("MAG",$J,"ROW") Q "RTN","RACNLU",12,0) ; "RTN","RACNLU",13,0) SEL ; "RTN","RACNLU",14,0) K ^TMP($J,"RAEX") S RACNT=0 G ADC:X["-" S RAFST=$S(X:X-.01,1:0),RAEND=$S(X:X,1:99999),X="",RAIX="AE" "RTN","RACNLU",15,0) ;S RAXHOLD=X ;don't need MAG calls anymore 111300 "RTN","RACNLU",16,0) ;I $$IMAGE^RARIC1 D MED^MAGSET3,ERASE^MAGSET3 "RTN","RACNLU",17,0) ;S X=RAXHOLD K RAXHOLD "RTN","RACNLU",18,0) F RACN=RAFST:0 Q:X="^"!(X>0) S RACN=$O(^RADPT(RAIX,RACN)) Q:RACN'>0!(RACN>RAEND) F RADFN=0:0 S RADFN=$O(^RADPT(RAIX,RACN,RADFN)) Q:RADFN'>0 S RADTI=$O(^(RADFN,0)),RACNI=$O(^(RADTI,0)) S X="" D PRT Q:X="^"!(X>0) "RTN","RACNLU",19,0) G CHK "RTN","RACNLU",20,0) ADC ;S RAIX="ADC",RACN=$P(X,"-",2),RADTCN=X,X="" "RTN","RACNLU",21,0) S RAIX="ADC",RACN=$P(X,"-",$L(X,"-")),RADTCN=$S($L(X,"-")=3:$P(X,"-",2,3),1:X),X="" "RTN","RACNLU",22,0) F RADFN=0:0 S RADFN=$O(^RADPT(RAIX,RADTCN,RADFN)) Q:RADFN'>0 S RADTI=$O(^(RADFN,0)),RACNI=$O(^(RADTI,0)) S X="" D PRT Q:X="^"!(X>0) "RTN","RACNLU",23,0) I 'RACNT D ADC1 "RTN","RACNLU",24,0) CHK Q:X="^"!(X>0) I 'RACNT W !?3,*7,"No matches found!" Q "RTN","RACNLU",25,0) ;Q:X="^"!(X>0) I 'RACNT W !?3,*7,"No matches found!" Q "RTN","RACNLU",26,0) I RACNT=1 S X=1,Y=^TMP($J,"RAEX",1) D:$D(RAOPT("EDITCN")) CHECK Q "RTN","RACNLU",27,0) CHK1 Q:'(RACNT#15) W !,"CHOOSE FROM 1-",RACNT,": " R X:DTIME S:'$T!(X="") X="^" Q:X="^" I X["?" D HLP G CHK1 "RTN","RACNLU",28,0) I '$D(^TMP($J,"RAEX",+X)) S X="^" W *7," ??" Q "RTN","RACNLU",29,0) S Y=^TMP($J,"RAEX",+X) D:$D(RAOPT("EDITCN")) CHECK Q "RTN","RACNLU",30,0) PRT S RAFL=0 Q:'$D(^RADPT(RADFN,0))!('$D(^DPT(RADFN,0))) S RANME=^(0),RASSN=$$SSN^RAUTL,RANME=$P(RANME,"^") "RTN","RACNLU",31,0) K RADIV ;this var must be cleared so can detect bad ^RADPT("AE" ;111500 "RTN","RACNLU",32,0) I $D(^RADPT(RADFN,"DT",RADTI,0)) D Q:'RAFL "RTN","RACNLU",33,0) . S RANODE=$G(^RADPT(RADFN,"DT",RADTI,0)) "RTN","RACNLU",34,0) . S RADIV=+$P(RANODE,"^",3),RAIMAGE=+$P(RANODE,"^",2),RADIVIEN=RADIV "RTN","RACNLU",35,0) . S RADIV=+$G(^RA(79,RADIV,0)),RADIV=$P($G(^DIC(4,RADIV,0)),"^") "RTN","RACNLU",36,0) . S:RADIV']"" RADIV="Unknown" "RTN","RACNLU",37,0) . S RAIMAGE=$P($G(^RA(79.2,RAIMAGE,0)),"^") "RTN","RACNLU",38,0) . S:RAIMAGE']"" RAIMAGE="Unknown" "RTN","RACNLU",39,0) . S (Y,RADTE)=+$P(RANODE,"^") D D^RAUTL S RADATE=Y "RTN","RACNLU",40,0) . I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S RAFL=1,Y=^(0) "RTN","RACNLU",41,0) . Q "RTN","RACNLU",42,0) I '$D(RADIV) Q ;possible corrupted "AE" active case x-ref on ^RADPT "RTN","RACNLU",43,0) ; pointing to a non-existent visit node "RTN","RACNLU",44,0) ; Note: if $D(ORVP) the screen logic is to be ignored. We have entered "RTN","RACNLU",45,0) ; through OE/RR. Even if we are not screening, the user may have "RTN","RACNLU",46,0) ; already selected various Division(s) and Imaging type(s) which are "RTN","RACNLU",47,0) ; in ^TMP($J,"RA D-TYPE" and ^TMP($J,"RA I-TYPE". If RANOSCRN is "RTN","RACNLU",48,0) ; defined, it means no screening by imaging types to which the "RTN","RACNLU",49,0) ; user has access privilege. "RTN","RACNLU",50,0) I '$D(ORVP),($D(RANOSCRN)),('$D(RADUPSCN)) I $D(^TMP($J,"RA D-TYPE"))!($D(^TMP($J,"RA I-TYPE"))) Q:'$D(^TMP($J,"RA D-TYPE",RADIV))!('$D(^TMP($J,"RA I-TYPE",RAIMAGE))) "RTN","RACNLU",51,0) ; If in 'Case No. Exam Edit' option, skip i-type check in the next line "RTN","RACNLU",52,0) I '$D(ORVP),('$D(RADUPSCN)),('$D(RAOPT("EDITCN"))) Q:$$IMGTY^RAUTL12("e",RADFN,RADTI)'=RAIMGTY&('$D(RANOSCRN)) "RTN","RACNLU",53,0) S RAST=+$P(Y,"^",3),RARPT=+$P(Y,"^",17),RAPRC=$S($D(^RAMIS(71,+$P(Y,"^",2),0)):$P(^(0),"^"),1:"Unknown"),RACNT=RACNT+1 "RTN","RACNLU",54,0) S ^TMP($J,"RAEX",RACNT)=RADFN_"^"_RADTI_"^"_RACNI_"^"_RANME_"^"_RASSN_"^"_RADATE_"^"_RADTE_"^"_RACN_"^"_RAPRC_"^"_RARPT_"^"_RAST "RTN","RACNLU",55,0) ;I $$IMAGE^RARIC1 D DISPA^MAGRIC ; don't need MAG calls anymore 111300 "RTN","RACNLU",56,0) I RACNT=1,$S('$D(RAEND):1,RAEND<99999:1,1:0),$D(RAVW),$O(^RADPT(RAIX,$S(RAIX="ADC":RADTCN,1:RACN),RADFN))'>0 S X=1,Y=^TMP($J,"RAEX",1) Q "RTN","RACNLU",57,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RACNLU",58,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:$$LCASE(RADTE,RACN)) "RTN","RACNLU",59,0) I $$USESSAN^RAHLRU1() D HD:RACNT=1 W !?1,RACNT,?7,RACNDSP W:$O(^RARPT(RARPT,2005,0)) ?22,"i" W ?24,$E(RAPRC,1,25),?50,$E(RANME,1,22),?74,$$SSN^RAUTL(RADFN,1) Q:RACNT#15 "RTN","RACNLU",60,0) I '$$USESSAN^RAHLRU1() D HD:RACNT=1 W !?1,RACNT,?7,$$LCASE(RADTE,RACN) W:$O(^RARPT(RARPT,2005,0)) ?22,"i" W ?24,$E(RAPRC,1,25),?50,$E(RANME,1,22),?74,$$SSN^RAUTL(RADFN,1) Q:RACNT#15 "RTN","RACNLU",61,0) PRT1 W !,"Type '^' to STOP, or",!,"CHOOSE FROM 1-",RACNT,": " R X:DTIME S:'$T X="^" Q:X="^"!(X="") I X["?" D HLP G PRT1 "RTN","RACNLU",62,0) I '$D(^TMP($J,"RAEX",+X)) W *7," ??" S X="^" Q "RTN","RACNLU",63,0) S X=+X,Y=^TMP($J,"RAEX",X) Q "RTN","RACNLU",64,0) ; "RTN","RACNLU",65,0) HD W !!,"Choice",?7,"Case No.",?24,"Procedure",?50,"Name",?74,"Pt ID",!,"------",?7,"---------------",?24,"---------",?50,"-----------------",?74,"------" Q "RTN","RACNLU",66,0) ; "RTN","RACNLU",67,0) SPACE I $D(^DISV($S($D(DUZ)#2:DUZ,1:0),"RA","CASE #")) S X=^("CASE #") I $D(^RADPT(+$P(X,"^"),"DT",+$P(X,"^",2),"P",+$P(X,"^",3),0)) S RADTX=$P($P(X,"^",2),"."),X=+^(0) S X=$$LCASE(9999999-RADTX,X) W " ",X K RADTX Q "RTN","RACNLU",68,0) S X="^" Q "RTN","RACNLU",69,0) ; "RTN","RACNLU",70,0) QUES W !,"Enter an active case number in the following form '999'..." "RTN","RACNLU",71,0) W !?10,"...or enter a completed case number as 'MMDDYY-999'" "RTN","RACNLU",72,0) W !?10,"...or enter a patient's name" "RTN","RACNLU",73,0) W !?10,"...or enter a patient's 9-digit SSN" "RTN","RACNLU",74,0) W !?10,"...or enter the first character of the patient's",!?13,"last name and the last four digits of their SSN." "RTN","RACNLU",75,0) ASKACT R !!,"Do you wish to see the entire list of active cases? NO// ",X:DTIME S X=$E(X) S:'$T!("Nn"[X) X="^" I "Yy"'[X,X'="^" W:X'="?" *7 W !!?3,"Enter 'YES' to list all active cases, or 'NO' not to." G ASKACT "RTN","RACNLU",76,0) S:"Yy"[X X="??" Q "RTN","RACNLU",77,0) HLP W !!?3,"Enter the number corresponding to the exam you wish to select.",! Q "RTN","RACNLU",78,0) LCASE(RADT,RACN) ; Pass back the long case number. "RTN","RACNLU",79,0) ; Input : RADT -> FM date (internal format) "RTN","RACNLU",80,0) ; RACN -> Case # "RTN","RACNLU",81,0) ; Output: long case number i.e, '010197-100' "RTN","RACNLU",82,0) ; RTK 3/16/2009 ADDED NEXT 2 LINES FOR USE WITH SSAN P47 "RTN","RACNLU",83,0) Q $TR($TR($$FMTE^XLFDT(RADT,"2FD")," ","0"),"/","")_"-"_RACN "RTN","RACNLU",84,0) CHECK ; Check if the exam selected is of the same imaging type as the sign-on "RTN","RACNLU",85,0) ; location. Must be in the 'Case No. Exam Edit' option. "RTN","RACNLU",86,0) Q:'$D(RAOPT("EDITCN")) N RAMASK,RARTRN S RAMASK=Y "RTN","RACNLU",87,0) I $$IMGTY^RAUTL12("e",$P(Y,"^"),$P(Y,"^",2))'=RAIMGTY D "RTN","RACNLU",88,0) . N X S RARTRN=$$SW^RAPSET1($$IMGTY^RAUTL12("e",$P(Y,"^"),$P(Y,"^",2)),RAIMGTY) "RTN","RACNLU",89,0) . Q "RTN","RACNLU",90,0) W:+$G(RARTRN) !!,$P(RARTRN,"^",2),$C(7) "RTN","RACNLU",91,0) S Y=RAMASK "RTN","RACNLU",92,0) I +$G(RARTRN) S X="^" K RADFN,RADTI,RACNI,RANME,RASSN,RADATE,RADTE,RACN,RAPRC,RARPT,RAST,RAEND,RAFST,RAIX "RTN","RACNLU",93,0) Q "RTN","RACNLU",94,0) ADC1 ; "RTN","RACNLU",95,0) S RAIX="ADC1" "RTN","RACNLU",96,0) F RADFN=0:0 S RADFN=$O(^RADPT(RAIX,RADTCN,RADFN)) Q:RADFN'>0 S RADTI=$O(^(RADFN,0)),RACNI=$O(^(RADTI,0)) S X="" D PRT Q:X="^"!(X>0) "RTN","RADD2") 0^27^B18850431 "RTN","RADD2",1,0) RADD2 ;HISC/GJC/CAH-Radiology Data Dictionary Utility Routine ;5/14/97 10:31 "RTN","RADD2",2,0) ;;5.0;Radiology/Nuclear Medicine;**84,47**;Mar 16, 1998;Build 21 "RTN","RADD2",3,0) ; "RTN","RADD2",4,0) ;Integration Agreements "RTN","RADD2",5,0) ;---------------------- "RTN","RADD2",6,0) ;EN^DDIOL(10142); FILE^DIE(2053);NOTE^ORX3(868);MES^XPDUTL(10141) "RTN","RADD2",7,0) ; "RTN","RADD2",8,0) EN1(RAX,RAY) ; Input transform for the .01 field (Procedure) for the Rad/Nuc "RTN","RADD2",9,0) ; Med Common Procedure file i.e, ^RAMIS(71.3 "RTN","RADD2",10,0) ; Procedure must not have an inactive date before today in file 71 "RTN","RADD2",11,0) ; Procedure in file 71 must have same imaging type as the one "RTN","RADD2",12,0) ; selected before editing this record in file 71.3 "RTN","RADD2",13,0) ; If 'Parent' type procedure, it must have at least 1 descendent "RTN","RADD2",14,0) ; 'RAX' is the value of the .01 field in ^RAMIS(71.3, "RTN","RADD2",15,0) ; 'RAY' are ien's of entries in ^RAMIS(71, "RTN","RADD2",16,0) I '$G(RAIMGTYI) Q 0 "RTN","RADD2",17,0) I $S('$D(^("I")):1,'^("I"):1,DT'>^("I"):1,1:0),$S(RAIMGTYI=$P($G(^RAMIS(71,+RAY,0)),"^",12):1,1:0),$S($P(^RAMIS(71,+RAY,0),U,6)'="P":1,$O(^RAMIS(71,+RAY,4,0)):1,1:0) "RTN","RADD2",18,0) Q $T "RTN","RADD2",19,0) ; "RTN","RADD2",20,0) CH(RAY,RAX) ; This subroutine will fire off the 'Radiology Request Cancel "RTN","RADD2",21,0) ; /Hold' notification as defined in the 'OE/RR NOTIFICATIONS' file. "RTN","RADD2",22,0) ; Only if request is either cancelled or held. Called from the set "RTN","RADD2",23,0) ; logic of the 'ACHN' xref in ^DD(75.1,5) field definition. "RTN","RADD2",24,0) ; "RTN","RADD2",25,0) ; Input variables: "RTN","RADD2",26,0) ; 'RAX'=Request status of the order, $S(X=1:'discontinued',X=3:'hold') "RTN","RADD2",27,0) ; 'RAY'=ien of the order in the RAD/NUC MED ORDERS file. "RTN","RADD2",28,0) ; "RTN","RADD2",29,0) Q:(RAY'=+RAY) Q:(RAX'=1)&(RAX'=3) "RTN","RADD2",30,0) N %,C,D,D0,DA,DC,DDER,DE,DG,DH,DI,DIC,DIE,DIEDA,DIEL,DIFLD,DIP,DIW,DIWT "RTN","RADD2",31,0) N DK,DL,DM,DN,DP,DQ,DR,DU,DV,DW,I,J,N,ORBPMSG,ORBXDATA,ORIFN,ORNOTE,ORVP "RTN","RADD2",32,0) N RA751,RADFN,RANME,RAOIFN,RAOLP,RAOPTN,RAORDS,RAOREA,RAOSTS,RAPARENT "RTN","RADD2",33,0) N RAPRC,RAXIT,X,Y "RTN","RADD2",34,0) S RA751=$G(^RAO(75.1,RAY,0)) Q:RA751']"" "RTN","RADD2",35,0) S RAOIFN=RAY,RADFN=+$P(RA751,"^") "RTN","RADD2",36,0) S RAPRC=$P($G(^RAMIS(71,+$P(RA751,"^",2),0)),"^"),ORVP=RADFN_";DPT(" "RTN","RADD2",37,0) S ORBPMSG=$S(RAX=1:"Discontinued - ",1:"On hold - ")_$E(RAPRC,1,17) "RTN","RADD2",38,0) S ORBXDATA=RAOIFN_","_RADFN,ORIFN=+$P(RA751,"^",7),ORNOTE(26)=1 "RTN","RADD2",39,0) D NOTE^ORX3 "RTN","RADD2",40,0) Q "RTN","RADD2",41,0) INACOM(RAD0) ; Check inactive date on the Rad/Nuc Med Procedure file (71) "RTN","RADD2",42,0) ; for the Common Procedure before setting our inactive procedure to "RTN","RADD2",43,0) ; active. Called from the 'RA COMMON PROCEDURE EDIT' input template. "RTN","RADD2",44,0) ; Option: Common Procedure Enter/Edit (13^RAMAIN2) "RTN","RADD2",45,0) ; Input : RAD0-ien of Rad/Nuc Med Common Procedure "RTN","RADD2",46,0) ; Output: if Common cannot be re-activated, reset the 'Inactive' field "RTN","RADD2",47,0) ; to 'yes'. "RTN","RADD2",48,0) N RAINA S RAINA=$P($G(^RAMIS(71,+$P($G(^RAMIS(71.3,RAD0,0)),"^"),"I")),"^") "RTN","RADD2",49,0) Q:RAINA=""!(RAINA>DT) "@15" ; we can inactivate the common "RTN","RADD2",50,0) N RAFDA,RAMSG "RTN","RADD2",51,0) S RAFDA(71.3,RAD0_",",4)="Y" D FILE^DIE("","RAFDA","") S RAMSG(1)=$C(7) "RTN","RADD2",52,0) S RAMSG(2)="You cannot add this procedure to the common procedure list" "RTN","RADD2",53,0) S RAMSG(3)="because it is inactivated in the Rad/Nuc Med Procedures file." "RTN","RADD2",54,0) S RAMSG(4)="You must first re-activate the procedure through the 'Procedure" "RTN","RADD2",55,0) S RAMSG(5)="Enter/Edit' option.",RAMSG(6)="" D MES^XPDUTL(.RAMSG) "RTN","RADD2",56,0) Q "@10" ; reset 'Inactive' to 'yes', re-edit field. "RTN","RADD2",57,0) ; "RTN","RADD2",58,0) EN2() ; called from ^DD(74,0,"ID","WRITE") "RTN","RADD2",59,0) ; display long case #'s in the same print set as current record "RTN","RADD2",60,0) N RA1,RA2 "RTN","RADD2",61,0) S RA1=0,RA2="" "RTN","RADD2",62,0) ; F S RA1=$O(^RARPT(Y,1,"B",RA1)) Q:'RA1 S RA2=RA2_$S(RA2="":"-",1:",-")_$P(RA1,"-",2) "RTN","RADD2",63,0) F S RA1=$O(^RARPT(Y,1,"B",RA1)) Q:'RA1 S RA2=RA2_$S(RA2="":"-",1:",-")_$P(RA1,"-",$L(RA1,"-")) ;P47 to accommodate possible SSAN format "RTN","RADD2",64,0) Q RA2 "RTN","RADD2",65,0) USUAL(RADA,RAX) ; To insure that the USUAL DOSE value falls between the "RTN","RADD2",66,0) ; HIGH ADULT DOSE and the LOW ADULT DOSE. "RTN","RADD2",67,0) ; Input Variables: "RTN","RADD2",68,0) ; RADA -> top level/sub-file level IEN's "RTN","RADD2",69,0) ; RAX -> value input by the user "RTN","RADD2",70,0) ; Output Variable: $S(1: value is accepted, 0: value not accepted) "RTN","RADD2",71,0) ; "RTN","RADD2",72,0) Q:RAX="" 0 ; X does not exist "RTN","RADD2",73,0) N RA7108,RAH,RAL S RA7108=$G(^RAMIS(71,RADA(1),"NUC",RADA,0)) "RTN","RADD2",74,0) S RAH=$P(RA7108,"^",5),RAL=$P(RA7108,"^",6) "RTN","RADD2",75,0) S RAH=$S(RAH="":99999.9999,1:RAH),RAL=$S(RAL="":.0001,1:RAL) "RTN","RADD2",76,0) I (+RAXRAH) D Q 0 ; value is not accepted "RTN","RADD2",77,0) . N RARRY S RARRY(1)="The 'USUAL DOSE' must fall within the range of: " "RTN","RADD2",78,0) . S RARRY(1)=RARRY(1)_RAL_" - "_RAH_" " "RTN","RADD2",79,0) . D EN^DDIOL(.RARRY) "RTN","RADD2",80,0) . Q "RTN","RADD2",81,0) E Q 1 ; value accepted "RTN","RADD2",82,0) ; "RTN","RADD2",83,0) RANGE(RADA) ; Determine the range in which the 'USUAL DOSE' must fall "RTN","RADD2",84,0) ; Input Variables: "RTN","RADD2",85,0) ; RADA -> top level/sub-file level IEN's "RTN","RADD2",86,0) ; Output Variable: "RTN","RADD2",87,0) ; RANGE -> the range in which the 'USUAL DOSE' must fall "RTN","RADD2",88,0) N RA7108,RAH,RAL "RTN","RADD2",89,0) S RA7108=$G(^RAMIS(71,RADA(1),"NUC",RADA,0)) "RTN","RADD2",90,0) S RAH=$P(RA7108,"^",5),RAL=$P(RA7108,"^",6) "RTN","RADD2",91,0) S RAH=$S(RAH="":99999.9999,1:RAH),RAL=$S(RAL="":.0001,1:RAL) "RTN","RADD2",92,0) Q RAL_"-"_RAH "RTN","RADD2",93,0) MEDOSE(RAY,RADT) ; Determine if this individual (RAY) is authorized to "RTN","RADD2",94,0) ; administer medications. Called from ^DD(70.15,4,12.1) "RTN","RADD2",95,0) ; Input : RAY (pnt to 200) - the individual being checked at the moment "RTN","RADD2",96,0) ; RADT - Date of the examination "RTN","RADD2",97,0) ; Output: '1' - user is authorized to administer medications, else '0' "RTN","RADD2",98,0) ; "RTN","RADD2",99,0) Q:$D(^VA(200,"ARC","R",RAY)) 1 ; Rad/Nuc Med Class: Resident "RTN","RADD2",100,0) Q:$D(^VA(200,"ARC","S",RAY)) 1 ; Rad/Nuc Med Class: Staff "RTN","RADD2",101,0) Q:$D(^VA(200,"ARC","T",RAY)) 1 ; Rad/Nuc Med Class: Technologist "RTN","RADD2",102,0) Q:$D(^XUSEC("ORES",RAY)) 1 Q:$D(^XUSEC("ORELSE",RAY)) 1 "RTN","RADD2",103,0) N RAUTH S RAUTH=$G(^VA(200,RAY,"PS")) "RTN","RADD2",104,0) ; If authorized to write med orders ($P(RAUTH,"^")=1) and inactivation "RTN","RADD2",105,0) ; date null -OR- inactivation date greater than or equal to the exam "RTN","RADD2",106,0) ; date individual is authorized. "RTN","RADD2",107,0) Q:+$P(RAUTH,"^")&($S('$P(RAUTH,"^",4):1,$P(RAUTH,"^",4)'4)&(RADTE0!RAXIT I $D(^(RADTI,0)) S Y=^(0),RALOC=+$P(Y,"^",4),(RADTE,Y)=+Y Q:(RASEQ>4)&(RADTE key to continue.",X:DTIME "RTN","RADEM1",18,0) Q K %,%H,DIC,POP,RACNFL,RAORFL,RACODE,RACONT,RABAR,RABARFL,RACHKDT,RACHKDT1,RACN,RACNI,RADATE,RADTE,RADTI,RAPR1,RAPRI,RASEQ,RAST,RASTI,RAXIT,RAZDFN,RAZDTI,RAZCNI Q "RTN","RADEM1",19,0) ; "RTN","RADEM1",20,0) RACN S RALOC=$S($D(^RA(79.1,RALOC,0)):$P(^(0),"^"),1:"") S RALOC=$S($D(^SC(+RALOC,0)):$P(^(0),"^"),1:"Unknown") "RTN","RADEM1",21,0) F RACNI=0:0 Q:(RASEQ>4)&(RADTE0!RAXIT I $D(^(RACNI,0)) S Y=^(0) D PRT "RTN","RADEM1",22,0) Q "RTN","RADEM1",23,0) ; "RTN","RADEM1",24,0) PRT N RAESITY,RAITYPE "RTN","RADEM1",25,0) S RAPRI=+$P(Y,"^",2),RAPR1=99 S:$D(^RAMIS(71,RAPRI,0)) RAPR1=$P(^(0),"^") S RABAR=0 "RTN","RADEM1",26,0) I $P(Y,U,10)="Y" D "RTN","RADEM1",27,0) .I RADTE'0) S (RABAR,RAORFL)=1,RACODE=" **" "RTN","RADEM1",29,0) .I RADTE'(IOSL-4)) D "RTN","RADEM1",48,0) . N DIR S DIR(0)="E" D ^DIR S RAXIT=$S(Y'>0:1,1:0) "RTN","RADEM1",49,0) . I 'RAXIT W @IOF D HDR "RTN","RADEM1",50,0) . Q "RTN","RADEM1",51,0) Q "RTN","RADEM1",52,0) ORDER ; Check for pat rad orders before registering a patient in rad "RTN","RADEM1",53,0) ; Created by GJC@1/3/94 "RTN","RADEM1",54,0) N RALP,RA751,DIROUT,DIRUT,DTOUT,DUOUT S (RALP,RAXIT)=0 "RTN","RADEM1",55,0) F S RALP=$O(^RAO(75.1,"B",RADFN,RALP)) Q:RALP'>0!(RAXIT) D "RTN","RADEM1",56,0) . Q:$D(^RADPT("AO",RALP,RADFN))\10 ;Check for entry in file 70. "RTN","RADEM1",57,0) . Q:+$P($G(^RAO(75.1,RALP,0)),U,5)<3 "RTN","RADEM1",58,0) . S RA751(0)=$G(^RAO(75.1,RALP,0)),RA751(2)=$P(RA751(0),U,2) "RTN","RADEM1",59,0) . S RA751(16)=$P(RA751(0),U,16),RA751(20)=$P(RA751(0),U,20) "RTN","RADEM1",60,0) . S RA751(5)=+$P(RA751(0),U,5) Q:RA751(5)=1 ;GJC@4/4/94 Cancelled xam "RTN","RADEM1",61,0) . S Y=RA751(2),C=$P($G(^DD(75.1,2,0)),U,2) D:Y]"" Y^DIQ S RA751(2)=Y "RTN","RADEM1",62,0) . S Y=RA751(20),C=$P($G(^DD(75.1,20,0)),U,2) D:Y]"" Y^DIQ S RA751(20)=Y "RTN","RADEM1",63,0) . I $$USESSAN^RAHLRU1() W !?18,$E(RA751(2),1,28),?56,"Ord " "RTN","RADEM1",64,0) . I '$$USESSAN^RAHLRU1() W !?10,$E(RA751(2),1,28),?51,"Ord " "RTN","RADEM1",65,0) . W $S(RA751(16)]"":$$FMTE^XLFDT(RA751(16),"2D"),1:"") "RTN","RADEM1",66,0) . ; prints 'SUBMIT REQUEST TO' data "RTN","RADEM1",67,0) . I $$USESSAN^RAHLRU1() W ?68,$E(RA751(20),1,12) "RTN","RADEM1",68,0) . I '$$USESSAN^RAHLRU1() W ?67,$E(RA751(20),1,12) "RTN","RADEM1",69,0) . I $E(IOST,1,2)="C-",($Y>(IOSL-4)) D "RTN","RADEM1",70,0) .. K DIR S DIR(0)="E" D ^DIR K DIR S:'+Y RAXIT=1 "RTN","RADEM1",71,0) .. I 'RAXIT W @IOF D HDR "RTN","RADEM1",72,0) .. Q "RTN","RADEM1",73,0) . Q "RTN","RADEM1",74,0) Q "RTN","RADEM1",75,0) HDR ; Header "RTN","RADEM1",76,0) ; Created by GJC@1/3/94 ; modified for SSAN by RTK 3/19/09 "RTN","RADEM1",77,0) ; The variable: RAOPT("ORDEREXAM") is defined in the entry action of "RTN","RADEM1",78,0) ; the option RA ORDEREXAM. It is subsequently kill in the exit action "RTN","RADEM1",79,0) ; of the option. "RTN","RADEM1",80,0) D HOME^%ZIS W:$D(RAOPT("ORDEREXAM"))#2 @IOF "RTN","RADEM1",81,0) I $$USESSAN^RAHLRU1() W !!,"Case #",?18,"Last 5 Procedures/New Orders",?47,"Exam Dt",?56,"Exam Status",?68,"Imaging Loc." "RTN","RADEM1",82,0) I $$USESSAN^RAHLRU1() W !,"----------------",?18,"----------------------------",?47,"--------",?56,"-----------",?68,"------------" "RTN","RADEM1",83,0) I '$$USESSAN^RAHLRU1() W !!,"Case #",?10,"Last 5 Procedures/New Orders",?39,"Exam Date",?51,"Status of Exam",?67,"Imaging Loc." "RTN","RADEM1",84,0) I '$$USESSAN^RAHLRU1() W !,"------",?10,"----------------------------",?39,"---------",?51,"--------------",?67,"------------" "RTN","RADEM1",85,0) Q "RTN","RADEM1",86,0) ; "RTN","RADEM1",87,0) CM(RADFN,RADTI,RACNI) ;Return the contrast media used while performing an "RTN","RADEM1",88,0) ;exam. "RTN","RADEM1",89,0) ;Input: RADFN=patient DFN "RTN","RADEM1",90,0) ; RADTI=inverse date/time of exam "RTN","RADEM1",91,0) ; RACNI=IEN of an individual case "RTN","RADEM1",92,0) ;Return: contrast media used with exam delimited by ', '. "RTN","RADEM1",93,0) N I,X S X="",I=0 "RTN","RADEM1",94,0) F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",I)) Q:'I D "RTN","RADEM1",95,0) .S I(0)=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",I,0),U) "RTN","RADEM1",96,0) .S X=X_$$EXTERNAL^DILFD(70.3225,.01,"",I(0))_", " "RTN","RADEM1",97,0) .Q "RTN","RADEM1",98,0) I $L(X,", ")'>2 S X=$P(X,", ") "RTN","RADEM1",99,0) E S X=$P(X,", ",1,($L(X,", ")-1)) "RTN","RADEM1",100,0) Q X "RTN","RADEM1",101,0) ; "RTN","RADLQ1") 0^29^B33800278 "RTN","RADLQ1",1,0) RADLQ1 ;HISC/GJC AISC/MJK,RMO-Delq Status/Incomplete Rpt's ;10/30/97 15:02 "RTN","RADLQ1",2,0) ;;5.0;Radiology/Nuclear Medicine;**15,97,47**;Mar 16, 1998;Build 21 "RTN","RADLQ1",3,0) ;'RALL' will be defined in the entry action of RA INCOMPLETE "RTN","RADLQ1",4,0) I $D(DUZ),($O(RACCESS(DUZ,""))']"") D CHECK^RADLQ3(DUZ) "RTN","RADLQ1",5,0) S X=$$DIVLOC^RAUTL7() K ^TMP($J,"RADLQ") "RTN","RADLQ1",6,0) I X K:$D(RAPSTX) RAPSTX K RAQUIT,X,I,POP Q ; Selection process aborted. "RTN","RADLQ1",7,0) S INVMAXDT=9999999.9999,RAXIT=0 "RTN","RADLQ1",8,0) S RAHD(0)=$S($D(RALL):"Incomplete Exam",1:"Delinquent Status") "RTN","RADLQ1",9,0) S RAHD(0)=RAHD(0)_" Report" W @IOF,!?(IOM-$L(RAHD(0))\2),RAHD(0) "RTN","RADLQ1",10,0) D DISPXAM^RADLQ3 ; Display xam statuses "RTN","RADLQ1",11,0) I RAXIT D EXIT^RADLQ3 Q "RTN","RADLQ1",12,0) DEV D DATE^RAUTL I RAPOP D EXIT^RADLQ3 Q ; Quit if device not selected "RTN","RADLQ1",13,0) S RABEG=INVMAXDT-ENDDATE,RAEND=INVMAXDT-BEGDATE K DIR,X,Y "RTN","RADLQ1",14,0) S DIR(0)="SO^I:INPATIENT;O:OUTPATIENT;B:BOTH" "RTN","RADLQ1",15,0) S DIR("?",1)="This report can be broken out by" "RTN","RADLQ1",16,0) S DIR("?")="Outpatient, Inpatient, or Both." "RTN","RADLQ1",17,0) S DIR("A")="Report to include" D ^DIR K DIR "RTN","RADLQ1",18,0) I $D(DIRUT) D EXIT^RADLQ3 Q "RTN","RADLQ1",19,0) S RASORT1=Y "RTN","RADLQ1",20,0) W !!?5,"Now that you have selected ",Y(0) "RTN","RADLQ1",21,0) W " do you want to sort by",!?5,"Patient or Date ?" K X,Y "RTN","RADLQ1",22,0) S DIR(0)="SO^P:PATIENT;D:DATE" "RTN","RADLQ1",23,0) S DIR("?",1)="This allows you the flexibility to further" "RTN","RADLQ1",24,0) S DIR("?")="sort the report by Patient or Date." D ^DIR K DIR "RTN","RADLQ1",25,0) I $D(DIRUT) D EXIT^RADLQ3 Q "RTN","RADLQ1",26,0) S RASORT2=Y D ZEROUT^RADLQ3("RADLQ") "RTN","RADLQ1",27,0) I '$D(^TMP($J,"RADLQ")) D EXIT^RADLQ3 Q "RTN","RADLQ1",28,0) K RACCESS(DUZ,"DIV-IMG") W ! "RTN","RADLQ1",29,0) S ZTRTN="START^RADLQ1" S:$D(RALL) ZTSAVE("RALL")="" "RTN","RADLQ1",30,0) F RASV="RAHD(","RACRT(","RABEG","RAEND","RASORT1","RASORT2","INVMAXDT","RAXIT","RADIVNM","RAMDIV" D "RTN","RADLQ1",31,0) . S ZTSAVE(RASV)="" "RTN","RADLQ1",32,0) . Q "RTN","RADLQ1",33,0) S ZTSAVE("^TMP($J,""RA D-TYPE"",")="" "RTN","RADLQ1",34,0) S ZTSAVE("^TMP($J,""RADLQ"",")="" "RTN","RADLQ1",35,0) S ZTSAVE("^TMP($J,""RA I-TYPE"",")="" "RTN","RADLQ1",36,0) D ZIS^RAUTL I RAPOP D EXIT^RADLQ3 Q "RTN","RADLQ1",37,0) START ; start processing here "RTN","RADLQ1",38,0) U IO S $P(RALN1,"-",(IOM+1))="" "RTN","RADLQ1",39,0) S:$D(ZTQUEUED) ZTREQ="@" "RTN","RADLQ1",40,0) S $P(RALN2,"=",(IOM+1))="",(RAPG,RASTI)=0 "RTN","RADLQ1",41,0) F S RASTI=$O(^RADPT("AS",RASTI)) Q:'RASTI D Q:RAXIT "RTN","RADLQ1",42,0) . D RADFN:$S($D(RALL):1,$D(RACRT(RASTI)):1,1:0) "RTN","RADLQ1",43,0) . Q "RTN","RADLQ1",44,0) K RADIV("I") D:'RAXIT PRINT^RADLQ2 "RTN","RADLQ1",45,0) I 'RAXIT D "RTN","RADLQ1",46,0) . S RADIVNM=$$DIVTOT^RACMP("RADLQ") Q:'RADIVNM "RTN","RADLQ1",47,0) . S RAXIT=$$EOS^RAUTL5() Q:RAXIT S RAFLAG="" D HDR^RADLQ2 "RTN","RADLQ1",48,0) . D:'RAXIT LIST^RADLQ3 "RTN","RADLQ1",49,0) . Q "RTN","RADLQ1",50,0) S RAXIT=$$EOS^RAUTL5() ;cause screen pause for user "RTN","RADLQ1",51,0) D EXIT^RADLQ3 "RTN","RADLQ1",52,0) Q "RTN","RADLQ1",53,0) RADFN ; $ order through rad patients ien's "RTN","RADLQ1",54,0) S RADFN=0 "RTN","RADLQ1",55,0) F S RADFN=$O(^RADPT("AS",RASTI,RADFN)) Q:'RADFN D Q:RAXIT "RTN","RADLQ1",56,0) . F RADTI=RABEG-1:0 S RADTI=$O(^RADPT("AS",RASTI,RADFN,RADTI)) Q:'RADTI!(RADTI>RAEND) D Q:RAXIT "RTN","RADLQ1",57,0) .. S RADTE=INVMAXDT-RADTI D RACNI "RTN","RADLQ1",58,0) .. Q "RTN","RADLQ1",59,0) . Q "RTN","RADLQ1",60,0) Q "RTN","RADLQ1",61,0) RACNI ; $ order through case # "RTN","RADLQ1",62,0) S RACNI=0 "RTN","RADLQ1",63,0) F S RACNI=$O(^RADPT("AS",RASTI,RADFN,RADTI,RACNI)) Q:'RACNI D SORT Q:RAXIT "RTN","RADLQ1",64,0) Q "RTN","RADLQ1",65,0) SORT ; sort logic "RTN","RADLQ1",66,0) S RAREGEX(0)=$G(^RADPT(RADFN,"DT",RADTI,0)) Q:RAREGEX(0)']"" "RTN","RADLQ1",67,0) S RADIV("I")=+$P(RAREGEX(0),"^",3) Q:RADIV("I")=0 "RTN","RADLQ1",68,0) S RADIV("I")=$S($D(^RA(79,RADIV("I"),0)):$P(^(0),"^"),1:0) "RTN","RADLQ1",69,0) S RADIV=$S($D(^DIC(4,RADIV("I"),0)):$P(^(0),"^"),1:0) "RTN","RADLQ1",70,0) Q:'$D(^TMP($J,"RA D-TYPE",RADIV)) "RTN","RADLQ1",71,0) S RADIV=RADIV("I"),RAPAT(0)=$G(^DPT(RADFN,0)) "RTN","RADLQ1",72,0) S RANME=$S($P(RAPAT(0),"^")]"":$P(RAPAT(0),"^"),1:"Unknown") "RTN","RADLQ1",73,0) S RASSN=$$SSN^RAUTL "RTN","RADLQ1",74,0) S RAEXAM(0)=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) Q:RAEXAM(0)']"" "RTN","RADLQ1",75,0) S RAIPHY="Unknown" "RTN","RADLQ1",76,0) S:$P(RAEXAM(0),"^",15)]"" RAIPHY=$P($G(^VA(200,+$P(RAEXAM(0),"^",15),0)),"^") "RTN","RADLQ1",77,0) S:$P(RAEXAM(0),"^",12)]""&(RAIPHY="Unknown") RAIPHY=$P($G(^VA(200,+$P(RAEXAM(0),"^",12),0)),"^") "RTN","RADLQ1",78,0) K RATECH S RATD4=+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) "RTN","RADLQ1",79,0) I RATD4 D ; Obtain the first 'tech' encountered "RTN","RADLQ1",80,0) . S RATECH=$E($$GET1^DIQ(200,+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",RATD4,0))_",",.01),1,15) "RTN","RADLQ1",81,0) . Q "RTN","RADLQ1",82,0) K RATD4 S:'$L($G(RATECH)) RATECH="Unknown" "RTN","RADLQ1",83,0) S RACN=+$P(RAEXAM(0),"^"),RAPRC=+$P(RAEXAM(0),"^",2) "RTN","RADLQ1",84,0) S RAPRC=$S($D(^RAMIS(71,RAPRC,0)):$P(^(0),"^"),1:"Unknown") "RTN","RADLQ1",85,0) S RAST=+$P(RAEXAM(0),"^",3),RADT=$P(RADTE,".") "RTN","RADLQ1",86,0) S RAITYPE("I")=$S($D(^RA(72,RAST,0)):+$P(^(0),"^",7),1:0) "RTN","RADLQ1",87,0) S RAITYPE=$S($D(^RA(79.2,RAITYPE("I"),0)):$P(^(0),"^"),1:"Unknown") "RTN","RADLQ1",88,0) Q:'$D(^TMP($J,"RA I-TYPE",RAITYPE)) "RTN","RADLQ1",89,0) S:'$D(^RA(72,RAST,0)) RAST="Unknown" "RTN","RADLQ1",90,0) S:$D(^RA(72,RAST,0)) RAST=$P(^(0),"^") "RTN","RADLQ1",91,0) S RADT=$E(RADT,4,5)_"/"_$E(RADT,6,7)_"/"_$E(RADT,2,3) "RTN","RADLQ1",92,0) ; 6th piece: Ward Location <-> 8th piece: Principal Clinic "RTN","RADLQ1",93,0) ; 9th piece: Contact/Sharing Source <-> 17th piece: Report Text "RTN","RADLQ1",94,0) F RA=6,8,9,17 S RA(RA)=+$P(RAEXAM(0),"^",RA) "RTN","RADLQ1",95,0) S RA("R")=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"R")) "RTN","RADLQ1",96,0) S RAWHE=$S($D(^DIC(42,RA(6),0)):$P(^(0),"^"),$D(^SC(RA(8),0)):$P(^(0),"^"),$D(^DIC(34,RA(9),0)):$P(^(0),"^"),RA("R")]"":RA("R"),1:"Unknown") "RTN","RADLQ1",97,0) S RAVAR=$S($D(^DIC(42,RA(6),0)):"I",1:"O") "RTN","RADLQ1",98,0) Q:RASORT1'="B"&(RASORT1'=RAVAR) "RTN","RADLQ1",99,0) S RARP=$S(+$O(^RARPT(RA(17),"R",0)):"Yes",+$O(^RARPT(RA(17),"I",0)):"Yes",1:"No") "RTN","RADLQ1",100,0) S RAVRFIED=$P($G(^RARPT(RA(17),0)),U,5) S RAVRFIED=$S(RAVRFIED="D":"Draft",RAVRFIED="R":"Released",RAVRFIED="PD":"Prb Drft",RAVRFIED="V":"Verified",RAVRFIED="EF":"Elec. F.",1:"No Rpt") "RTN","RADLQ1",101,0) I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT "RTN","RADLQ1",102,0) ;S ^TMP($J,"RADLQ",RADIV,RAITYPE,RAVAR,$S(RASORT2="P":RANME,1:$P(RADTE,".")),$S(RASORT2="P":$P(RADTE,"."),1:RANME),RACN)=RACN_"^"_RAPRC_"^"_RAST_"^"_RADT_"^"_RAWHE_"^"_RARP_"^"_RASSN_"^"_RAVRFIED_"^"_RAIPHY_"^"_RATECH "RTN","RADLQ1",103,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RADLQ1",104,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN) "RTN","RADLQ1",105,0) I $$USESSAN^RAHLRU1() D "RTN","RADLQ1",106,0) .S ^TMP($J,"RADLQ",RADIV,RAITYPE,RAVAR,$S(RASORT2="P":RANME,1:$P(RADTE,".")),$S(RASORT2="P":$P(RADTE,"."),1:RANME),RACN)=RACNDSP_"^"_RAPRC_"^"_RAST_"^"_RADT_"^"_RAWHE_"^"_RARP_"^"_RASSN_"^"_RAVRFIED_"^"_RAIPHY_"^"_RATECH "RTN","RADLQ1",107,0) I '$$USESSAN^RAHLRU1() D "RTN","RADLQ1",108,0) .S ^TMP($J,"RADLQ",RADIV,RAITYPE,RAVAR,$S(RASORT2="P":RANME,1:$P(RADTE,".")),$S(RASORT2="P":$P(RADTE,"."),1:RANME),RACN)=RACN_"^"_RAPRC_"^"_RAST_"^"_RADT_"^"_RAWHE_"^"_RARP_"^"_RASSN_"^"_RAVRFIED_"^"_RAIPHY_"^"_RATECH "RTN","RADLQ1",109,0) S ^TMP($J,"RADLQ")=+$G(^TMP($J,"RADLQ"))+1 "RTN","RADLQ1",110,0) S ^TMP($J,"RADLQ",RADIV)=+$G(^TMP($J,"RADLQ",RADIV))+1 "RTN","RADLQ1",111,0) S ^TMP($J,"RADLQ",RADIV,RAITYPE)=+$G(^TMP($J,"RADLQ",RADIV,RAITYPE))+1 "RTN","RADLQ1",112,0) S ^TMP($J,"RADLQ",RADIV,RAITYPE,RAVAR)=+$G(^TMP($J,"RADLQ",RADIV,RAITYPE,RAVAR))+1 "RTN","RADLQ1",113,0) Q "RTN","RADLQ2") 0^30^B16418030 "RTN","RADLQ2",1,0) RADLQ2 ;HISC/GJC-Delq Status/Incomplete Rpt's ;3/6/97 08:50 "RTN","RADLQ2",2,0) ;;5.0;Radiology/Nuclear Medicine;**15,47**;Mar 16, 1998;Build 21 "RTN","RADLQ2",3,0) DATE ; Sort by date "RTN","RADLQ2",4,0) S RADIV="" F S RADIV=$O(^TMP($J,"RADLQ",RADIV)) Q:RADIV']"" D Q:RAXIT "RTN","RADLQ2",5,0) . S RA1=$P($G(^DIC(4,RADIV,0)),"^"),RAITYPE="" "RTN","RADLQ2",6,0) . F S RAITYPE=$O(^TMP($J,"RADLQ",RADIV,RAITYPE)) Q:RAITYPE']"" D Q:RAXIT "RTN","RADLQ2",7,0) .. S RA2=RAITYPE,RAVAR="" "RTN","RADLQ2",8,0) .. F S RAVAR=$O(^TMP($J,"RADLQ",RADIV,RAITYPE,RAVAR)) Q:RAVAR']"" D Q:RAXIT "RTN","RADLQ2",9,0) ... S RADTE=0 "RTN","RADLQ2",10,0) ... F S RADTE=$O(^TMP($J,"RADLQ",RADIV,RAITYPE,RAVAR,RADTE)) Q:RADTE'>0 D Q:RAXIT "RTN","RADLQ2",11,0) .... S RANME="" "RTN","RADLQ2",12,0) .... F S RANME=$O(^TMP($J,"RADLQ",RADIV,RAITYPE,RAVAR,RADTE,RANME)) Q:RANME']"" D Q:RAXIT "RTN","RADLQ2",13,0) ..... S RACN=0 "RTN","RADLQ2",14,0) ..... F S RACN=$O(^TMP($J,"RADLQ",RADIV,RAITYPE,RAVAR,RADTE,RANME,RACN)) Q:RACN'>0 D Q:RAXIT "RTN","RADLQ2",15,0) ...... S RANODE=$G(^TMP($J,"RADLQ",RADIV,RAITYPE,RAVAR,RADTE,RANME,RACN)) "RTN","RADLQ2",16,0) ...... D:RANODE]"" OUTPUT^RADLQ3 "RTN","RADLQ2",17,0) ...... Q "RTN","RADLQ2",18,0) ..... Q "RTN","RADLQ2",19,0) .... Q "RTN","RADLQ2",20,0) ... Q "RTN","RADLQ2",21,0) .. D:'RAXIT IMGCHK "RTN","RADLQ2",22,0) .. Q "RTN","RADLQ2",23,0) . D:'RAXIT DIVCHK "RTN","RADLQ2",24,0) . Q "RTN","RADLQ2",25,0) Q "RTN","RADLQ2",26,0) HDR ; Header for reports "RTN","RADLQ2",27,0) I RAPG!($E(IOST,1,2)="C-") W @IOF "RTN","RADLQ2",28,0) S RAPG=RAPG+1 W !?(IOM-$L(RAHD(0))\2),RAHD(0) "RTN","RADLQ2",29,0) W !,"Division: ",$S($D(RAFLAG):"",1:RA1),?RATAB("HEAD"),"Page: ",RAPG "RTN","RADLQ2",30,0) W !,"Imaging Type: ",$S($D(RAFLAG):"",1:RA2),?RATAB("HEAD"),"Date: " "RTN","RADLQ2",31,0) W $$FMTE^XLFDT($$DT^XLFDT,1) "RTN","RADLQ2",32,0) W !,RALN2 "RTN","RADLQ2",33,0) I $$USESSAN^RAHLRU1() W !,"Patient Name",?RATAB(1),"Case #",?RATAB(2)+6,"Pt ID" "RTN","RADLQ2",34,0) I '$$USESSAN^RAHLRU1() W !,"Patient Name",?RATAB(1),"Case #",?RATAB(2),"Pt ID" "RTN","RADLQ2",35,0) W ?RATAB(3),"Date",?RATAB(4),"Ward/Clinic" "RTN","RADLQ2",36,0) W ?RATAB(5),"Rpt Stat",!?RATAB(6),"Procedure" "RTN","RADLQ2",37,0) W ?RATAB(7),"Exam Status",?RATAB(8),"Rpt Text" "RTN","RADLQ2",38,0) W ?RATAB(9),"Interp. Phys.",?RATAB(10),"Tech",!,RALN2 "RTN","RADLQ2",39,0) I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 "RTN","RADLQ2",40,0) Q "RTN","RADLQ2",41,0) PATIENT ; Sort by patient "RTN","RADLQ2",42,0) S RADIV="" F S RADIV=$O(^TMP($J,"RADLQ",RADIV)) Q:RADIV']"" D Q:RAXIT "RTN","RADLQ2",43,0) . S RA1=$P($G(^DIC(4,RADIV,0)),"^"),RAITYPE="" "RTN","RADLQ2",44,0) . F S RAITYPE=$O(^TMP($J,"RADLQ",RADIV,RAITYPE)) Q:RAITYPE']"" D Q:RAXIT "RTN","RADLQ2",45,0) .. S RA2=RAITYPE,RAVAR="" "RTN","RADLQ2",46,0) .. F S RAVAR=$O(^TMP($J,"RADLQ",RADIV,RAITYPE,RAVAR)) Q:RAVAR']"" D Q:RAXIT "RTN","RADLQ2",47,0) ... S RANME="" "RTN","RADLQ2",48,0) ... F S RANME=$O(^TMP($J,"RADLQ",RADIV,RAITYPE,RAVAR,RANME)) Q:RANME']"" D Q:RAXIT "RTN","RADLQ2",49,0) .... S RADTE=0 "RTN","RADLQ2",50,0) .... F S RADTE=$O(^TMP($J,"RADLQ",RADIV,RAITYPE,RAVAR,RANME,RADTE)) Q:RADTE'>0 D Q:RAXIT "RTN","RADLQ2",51,0) ..... S RACN=0 "RTN","RADLQ2",52,0) ..... F S RACN=$O(^TMP($J,"RADLQ",RADIV,RAITYPE,RAVAR,RANME,RADTE,RACN)) Q:RACN'>0 D Q:RAXIT "RTN","RADLQ2",53,0) ...... S RANODE=$G(^TMP($J,"RADLQ",RADIV,RAITYPE,RAVAR,RANME,RADTE,RACN)) "RTN","RADLQ2",54,0) ...... D:RANODE]"" OUTPUT^RADLQ3 "RTN","RADLQ2",55,0) ...... Q "RTN","RADLQ2",56,0) ..... Q "RTN","RADLQ2",57,0) .... Q "RTN","RADLQ2",58,0) ... Q "RTN","RADLQ2",59,0) .. D:'RAXIT IMGCHK "RTN","RADLQ2",60,0) .. Q "RTN","RADLQ2",61,0) . D:'RAXIT DIVCHK "RTN","RADLQ2",62,0) . Q "RTN","RADLQ2",63,0) Q "RTN","RADLQ2",64,0) PRINT ; Outputting the data "RTN","RADLQ2",65,0) S RATAB(1)=$S(IOM=132:40,1:22),RATAB(2)=$S(IOM=132:54,1:32) "RTN","RADLQ2",66,0) S RATAB(3)=$S(IOM=132:74,1:45),RATAB(4)=$S(IOM=132:90,1:55) "RTN","RADLQ2",67,0) S RATAB(5)=$S(IOM=132:120,1:72),RATAB(6)=1 ; for 132 & 80 column "RTN","RADLQ2",68,0) S RATAB(7)=$S(IOM=132:40,1:23),RATAB(8)=$S(IOM=132:75,1:36) "RTN","RADLQ2",69,0) S RATAB(9)=$S(IOM=132:90,1:46),RATAB(10)=$S(IOM=132:114,1:63) "RTN","RADLQ2",70,0) S RATAB("HEAD")=$S(IOM=132:102,1:62) "RTN","RADLQ2",71,0) S RADIV=$O(^TMP($J,"RADLQ","")),RA2=$O(^TMP($J,"RADLQ",RADIV,"")) "RTN","RADLQ2",72,0) S RA1=$P($G(^DIC(4,RADIV,0)),"^") D HDR "RTN","RADLQ2",73,0) D @$S(RASORT2="P":"PATIENT",1:"DATE") "RTN","RADLQ2",74,0) Q "RTN","RADLQ2",75,0) DIVCHK ; Output statistics within division "RTN","RADLQ2",76,0) N RA3 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR Q:RAXIT "RTN","RADLQ2",77,0) W !!?RATAB(6),"Division Total '"_RA1_"': ",+$G(^TMP($J,"RADLQ",RADIV)) "RTN","RADLQ2",78,0) S RA3=+$O(^TMP($J,"RADLQ",RADIV)) "RTN","RADLQ2",79,0) I RA3 N RA1,RA4 S RA1=$P($G(^DIC(4,RA3,0)),"^") D "RTN","RADLQ2",80,0) . S RA4=$O(^TMP($J,"RADLQ",RA3,"")) S:RA4]"" RA2=RA4 "RTN","RADLQ2",81,0) . S:$E(IOST,1,2)="C-" RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR "RTN","RADLQ2",82,0) . Q "RTN","RADLQ2",83,0) Q "RTN","RADLQ2",84,0) IMGCHK ; Output statistics within Imaging Type "RTN","RADLQ2",85,0) N RA5 "RTN","RADLQ2",86,0) I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR Q:RAXIT "RTN","RADLQ2",87,0) W !!?RATAB(6),"Imaging Type Total '"_RA2_"': " "RTN","RADLQ2",88,0) W +$G(^TMP($J,"RADLQ",RADIV,RA2)) "RTN","RADLQ2",89,0) S RA5=$O(^TMP($J,"RADLQ",RADIV,RAITYPE)) "RTN","RADLQ2",90,0) I RA5]"" S RA2=RA5 D "RTN","RADLQ2",91,0) . N RA1 S RA1=$P($G(^DIC(4,RADIV,0)),"^") "RTN","RADLQ2",92,0) . S:$E(IOST,1,2)="C-" RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR "RTN","RADLQ2",93,0) . Q "RTN","RADLQ2",94,0) Q "RTN","RADLQ3") 0^31^B23869496 "RTN","RADLQ3",1,0) RADLQ3 ;HISC/GJC-Delq Status/Incomplete Rpt's ;5/7/97 15:58 "RTN","RADLQ3",2,0) ;;5.0;Radiology/Nuclear Medicine;**87,93,47**;Mar 16, 1998;Build 21 "RTN","RADLQ3",3,0) ; 11/15/07 BAY/KAM RA*5*87 Rem Call 217642 change pat ssn to display last four "RTN","RADLQ3",4,0) ; 05/09/08 BAY/KAM RA*5*93 Rem Call 246868 correct printing of *** OUTPATIENT *** "RTN","RADLQ3",5,0) DISPXAM ; Display exam statuses for selected Imaging Types. These exam "RTN","RADLQ3",6,0) ; statuses need the 'DELINQUENT STATUS REPORT?' field tripped to "RTN","RADLQ3",7,0) ; 'yes' in file 72. "RTN","RADLQ3",8,0) N RA,RAHD,UNDRLN,X,Y,Z "RTN","RADLQ3",9,0) S RAHD(0)="The entries printed for this report will be based only" "RTN","RADLQ3",10,0) S RAHD(1)="on exams that are in one of the following statuses:" "RTN","RADLQ3",11,0) I '$D(RALL) D "RTN","RADLQ3",12,0) . W !!?(IOM-$L(RAHD(0))\2),RAHD(0) "RTN","RADLQ3",13,0) . W !?(IOM-$L(RAHD(1))\2),RAHD(1) "RTN","RADLQ3",14,0) . Q "RTN","RADLQ3",15,0) S X="" F S X=$O(^TMP($J,"RA I-TYPE",X)) Q:X']"" D Q:RAXIT "RTN","RADLQ3",16,0) . I $D(^RA(72,"AA",X)) S Y="" K UNDRLN D "RTN","RADLQ3",17,0) .. I '$D(RALL),($Y>(IOSL-4)) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF "RTN","RADLQ3",18,0) .. I '$D(RALL) S $P(UNDRLN,"-",($L(X)+1))="" W !!?10,X,!?10,UNDRLN "RTN","RADLQ3",19,0) .. F S Y=$O(^RA(72,"AA",X,Y)) Q:Y']"" D Q:RAXIT "RTN","RADLQ3",20,0) ... S Z=0 F S Z=+$O(^RA(72,"AA",X,Y,Z)) Q:'Z D Q:RAXIT "RTN","RADLQ3",21,0) .... S RA(0)=$G(^RA(72,Z,0)),RA(.3)=$G(^RA(72,Z,.3)) "RTN","RADLQ3",22,0) .... S RA(.3,15)=$P(RA(.3),"^",15) "RTN","RADLQ3",23,0) .... I RA(0)]"",(RA(.3)]""),(RA(.3,15)]""),("Yy"[RA(.3,15)) D "RTN","RADLQ3",24,0) ..... S RACRT(Z)="" "RTN","RADLQ3",25,0) ..... I '$D(RALL),($Y>(IOSL-4)) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D "RTN","RADLQ3",26,0) ...... W @IOF,!?10,X,!?10,UNDRLN "RTN","RADLQ3",27,0) ...... Q "RTN","RADLQ3",28,0) ..... W:'$D(RALL) !?15,$P(RA(0),"^") "RTN","RADLQ3",29,0) ..... Q "RTN","RADLQ3",30,0) .... Q "RTN","RADLQ3",31,0) ... Q "RTN","RADLQ3",32,0) .. Q "RTN","RADLQ3",33,0) . Q "RTN","RADLQ3",34,0) Q "RTN","RADLQ3",35,0) OUTPUT ; Print out the results "RTN","RADLQ3",36,0) N RAEOS I $D(RAVAR(0)),(RAVAR(0)'=RAVAR) S RAEOS=6 "RTN","RADLQ3",37,0) E S RAEOS=4 "RTN","RADLQ3",38,0) F I=1:1:$L(RANODE,"^") D "RTN","RADLQ3",39,0) . S @$P("RACN^RAPRC^RAST^RADT^RAWHE^RARP^RASSN^RAVRFIED^RAIPHY^RATECH","^",I)=$P(RANODE,"^",I) "RTN","RADLQ3",40,0) . Q "RTN","RADLQ3",41,0) I $Y>(IOSL-RAEOS) D Q:RAXIT "RTN","RADLQ3",42,0) . S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR^RADLQ2 "RTN","RADLQ3",43,0) . Q "RTN","RADLQ3",44,0) ; 05/09/08 BAY/KAM RA*5*93 Rem Call 246868 Added RAVAR Check to next "RTN","RADLQ3",45,0) ; line "RTN","RADLQ3",46,0) I RAEOS=6,RAVAR="O" D "RTN","RADLQ3",47,0) . N RASTR S RASTR="*** OUTPATIENT ***" "RTN","RADLQ3",48,0) . S RASTR(0)=$$REPEAT^XLFSTR(" ",((IOM-($L(RASTR)*3))\2)) "RTN","RADLQ3",49,0) . S RASTR(1)=RASTR_RASTR(0)_RASTR_RASTR(0)_RASTR "RTN","RADLQ3",50,0) . W !!,RASTR(1) "RTN","RADLQ3",51,0) . Q "RTN","RADLQ3",52,0) ; Note: Inform the user that the following data will be for outpatients. "RTN","RADLQ3",53,0) ; Since only inpatient and outpatient is possibly stored, any "RTN","RADLQ3",54,0) ; change in the variable RAVAR will be a change to 'outpatient'. "RTN","RADLQ3",55,0) ; 11/15/07 BAY/KAM RA*5*87 Rem Call 217642 Added next line "RTN","RADLQ3",56,0) S RASSN=$E(RASSN,8,11) "RTN","RADLQ3",57,0) I IOM=132 D ;132 column format "RTN","RADLQ3",58,0) . I $$USESSAN^RAHLRU1() D "RTN","RADLQ3",59,0) .. W !,RANME,?RATAB(1),RACN,?RATAB(2)+7,RASSN,?RATAB(3),RADT,?RATAB(4) "RTN","RADLQ3",60,0) .. W $E(RAWHE,1,25),?RATAB(5),RAVRFIED "RTN","RADLQ3",61,0) .. W !?RATAB(6),$E(RAPRC,1,30),?RATAB(7),$E(RAST,1,30) "RTN","RADLQ3",62,0) .. W ?RATAB(8),RARP,?RATAB(9),$E(RAIPHY,1,20),?RATAB(10),RATECH "RTN","RADLQ3",63,0) . I '$$USESSAN^RAHLRU1() D "RTN","RADLQ3",64,0) .. W !,RANME,?RATAB(1),RACN,?RATAB(2),RASSN,?RATAB(3),RADT,?RATAB(4) "RTN","RADLQ3",65,0) .. W $E(RAWHE,1,25),?RATAB(5),RAVRFIED "RTN","RADLQ3",66,0) .. W !?RATAB(6),$E(RAPRC,1,30),?RATAB(7),$E(RAST,1,30) "RTN","RADLQ3",67,0) .. W ?RATAB(8),RARP,?RATAB(9),$E(RAIPHY,1,20),?RATAB(10),RATECH "RTN","RADLQ3",68,0) . Q "RTN","RADLQ3",69,0) E D ;default to 80 column "RTN","RADLQ3",70,0) . I $$USESSAN^RAHLRU1() D "RTN","RADLQ3",71,0) .. W !,$E(RANME,1,20),?RATAB(1),RACN,?RATAB(2)+7,RASSN,?RATAB(3),RADT "RTN","RADLQ3",72,0) .. W ?RATAB(4),$E(RAWHE,1,15),?RATAB(5),RAVRFIED "RTN","RADLQ3",73,0) .. W !?RATAB(6),$E(RAPRC,1,20),?RATAB(7),$E(RAST,1,11) "RTN","RADLQ3",74,0) .. W ?RATAB(8),RARP,?RATAB(9),$E(RAIPHY,1,15),?RATAB(10),RATECH "RTN","RADLQ3",75,0) . I '$$USESSAN^RAHLRU1() D "RTN","RADLQ3",76,0) .. W !,$E(RANME,1,20),?RATAB(1),RACN,?RATAB(2),RASSN,?RATAB(3),RADT "RTN","RADLQ3",77,0) .. W ?RATAB(4),$E(RAWHE,1,15),?RATAB(5),RAVRFIED "RTN","RADLQ3",78,0) .. W !?RATAB(6),$E(RAPRC,1,20),?RATAB(7),$E(RAST,1,11) "RTN","RADLQ3",79,0) .. W ?RATAB(8),RARP,?RATAB(9),$E(RAIPHY,1,15),?RATAB(10),RATECH "RTN","RADLQ3",80,0) . Q "RTN","RADLQ3",81,0) W !,RALN1 "RTN","RADLQ3",82,0) S RAVAR(0)=RAVAR ; track the patient status: inpatient -or- outpatient "RTN","RADLQ3",83,0) Q "RTN","RADLQ3",84,0) CHECK(DUZ) ; Check for the existence of RACCESS. Pass in user's DUZ! "RTN","RADLQ3",85,0) S RAPSTX="" D SETVARS^RAPSET1(0) "RTN","RADLQ3",86,0) Q "RTN","RADLQ3",87,0) LIST ; List divisions and I-Types "RTN","RADLQ3",88,0) N A,B S A="" "RTN","RADLQ3",89,0) F S A=$O(^TMP($J,"RADLQ",A)) Q:A']"" D "RTN","RADLQ3",90,0) . W !!,"Division: ",$P($G(^DIC(4,A,0)),"^"),!?3,"Imaging Type(s): " "RTN","RADLQ3",91,0) . S B="" F S B=$O(^TMP($J,"RADLQ",A,B)) Q:B']"" D Q:RAXIT "RTN","RADLQ3",92,0) .. I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR^RADLQ2 Q:RAXIT "RTN","RADLQ3",93,0) .. W:$X>(IOM-30) !?($X+$L("Imaging Type(s): ")+3) W B,?($X+3) "RTN","RADLQ3",94,0) .. Q "RTN","RADLQ3",95,0) . Q "RTN","RADLQ3",96,0) I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HDR^RADLQ2 Q:RAXIT "RTN","RADLQ3",97,0) W !!?RATAB(6),"Total Over All Divisions: ",+$G(^TMP($J,"RADLQ")) "RTN","RADLQ3",98,0) Q "RTN","RADLQ3",99,0) EXIT ; Kill and quit "RTN","RADLQ3",100,0) K %DT,BEGDATE,DIROUT,DIRUT,DTOUT,DUOUT,ENDDATE,I,INVMAXDT,RA,RA1,RA2 "RTN","RADLQ3",101,0) K RABEG,RACN,RACNI,RACRT,RADFN,RADIV,RADIVNM,RADT,RADTE,RADTI,RAEND "RTN","RADLQ3",102,0) K RAEXAM,RAFLAG,RAHD,RAHEAD,RAIPHY,RAITYPE,RALN1,RALN2,RAMES,RANME "RTN","RADLQ3",103,0) K RANODE,RAPAT,RAPG,RAPOP,RAPRC,RAQUIT,RAREGEX,RARP,RASORT1,RASORT2 "RTN","RADLQ3",104,0) K RASSN,RAST,RASTI,RASV,RATAB,RATECH,RAVAR,RAVRFIED,RAWHE,RAXIT "RTN","RADLQ3",105,0) K X,Y,ZTDESC,ZTRTN,ZTSAVE "RTN","RADLQ3",106,0) K ^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE"),^TMP($J,"RADLQ") "RTN","RADLQ3",107,0) K:$D(RAPSTX) RACCESS,RAPSTX D CLOSE^RAUTL "RTN","RADLQ3",108,0) K DISYS,I,POP "RTN","RADLQ3",109,0) Q "RTN","RADLQ3",110,0) ZEROUT(SUB) ; Zero out the ^TMP($J global. "RTN","RADLQ3",111,0) N X,Y,Z "RTN","RADLQ3",112,0) S X="" F S X=$O(RACCESS(DUZ,"DIV-IMG",X)) Q:X']"" D "RTN","RADLQ3",113,0) . Q:'$D(^TMP($J,"RA D-TYPE",X)) S Y=0 "RTN","RADLQ3",114,0) . F S Y=+$O(^TMP($J,"RA D-TYPE",X,Y)) Q:'Y D "RTN","RADLQ3",115,0) .. S ^TMP($J,SUB,Y)=0,Z="" "RTN","RADLQ3",116,0) .. F S Z=$O(RACCESS(DUZ,"DIV-IMG",X,Z)) Q:Z']"" D "RTN","RADLQ3",117,0) ... Q:'$D(^TMP($J,"RA I-TYPE",Z)) S ^TMP($J,SUB,Y,Z)=0 "RTN","RADLQ3",118,0) ... I SUB="RADLQ" D "RTN","RADLQ3",119,0) .... S:RASORT1'="B" ^TMP($J,SUB,Y,Z,RASORT1)=0 "RTN","RADLQ3",120,0) .... S:RASORT1="B" ^TMP($J,SUB,Y,Z,"I")=0,^TMP($J,SUB,Y,Z,"O")=0 "RTN","RADLQ3",121,0) .... Q "RTN","RADLQ3",122,0) ... Q "RTN","RADLQ3",123,0) .. Q "RTN","RADLQ3",124,0) . Q "RTN","RADLQ3",125,0) Q "RTN","RADLY") 0^32^B30113114 "RTN","RADLY",1,0) RADLY ;HISC/GJC AISC/MJK,RMO-Rad Daily Log Report ;7/17/97 12:35 "RTN","RADLY",2,0) ;;5.0;Radiology/Nuclear Medicine;**15,47**;Mar 16, 1998;Build 21 "RTN","RADLY",3,0) ; setup raccess(duz,"LOC" raccess(duz,"DIV" raccess(duz,"IMG" "RTN","RADLY",4,0) I $O(RACCESS(DUZ,""))="" S RAPSTX="" D SETVARS^RAPSET1(0) "RTN","RADLY",5,0) ; Check access and "RTN","RADLY",6,0) ; setup raccess(duz,"DIV-IMG","chicago (ws),"general radiology" "RTN","RADLY",7,0) S RAXIT=$$SETUPDI^RAUTL7() G:RAXIT CLEAN "RTN","RADLY",8,0) ; Select Div "RTN","RADLY",9,0) ; setup ^tmp($j,"RA D-TYPE" "RTN","RADLY",10,0) D SELDIV^RAUTL7 "RTN","RADLY",11,0) I '$D(^TMP($J,"RA D-TYPE"))!(RAQUIT) K RACCESS(DUZ,"DIV-IMG") S RAXIT=1 G CLEAN "RTN","RADLY",12,0) ; Set imaging types as allowed by division(s) picked "RTN","RADLY",13,0) N X,X1,RACHK1 S X=0 "RTN","RADLY",14,0) ; setup ^tmp($j,"DIV-IMG" "RTN","RADLY",15,0) D SETUP^RAUTL7A "RTN","RADLY",16,0) ; setup ^tmp($j,"RA I-TYPE" "RTN","RADLY",17,0) F S X=$O(^TMP($J,"DIV-IMG",X)) Q:X'=+X I $D(RACCESS(DUZ,"IMG",X)) S ^TMP($J,"RA I-TYPE",$P($G(^RA(79.2,+X,0)),U),X)="" "RTN","RADLY",18,0) ; Select Img Loc "RTN","RADLY",19,0) ; setup ^tmp($j,"DIV-ITYP-ILOC" ^tmp($j,"RA LOC-TYPE" "RTN","RADLY",20,0) D SELLOC^RAUTL7 "RTN","RADLY",21,0) I '$D(^TMP($J,"RA LOC-TYPE"))!(RAQUIT) K RACESS(DUZ,"DIV-IMG"),^TMP($J,"DIV-ITYP-ILOC") S RAXIT=1 "RTN","RADLY",22,0) CLEAN K ^TMP($J,"DIV-IMG") "RTN","RADLY",23,0) ; "RTN","RADLY",24,0) I RAXIT K RAXIT K:$D(RAPSTX) RACCESS,RAPSTX,I,POP,RAQUIT Q "RTN","RADLY",25,0) ; loop thru raccess(duz,"DIV-IMG" to setup ^tmp($j,"RADLY", "RTN","RADLY",26,0) ; matching on ^tmp($j,"RA D-TYPE" and ^tmp($j,"RA I-TYPE" "RTN","RADLY",27,0) ; use new code in rtn radly1, instead of rtn radlq3 "RTN","RADLY",28,0) D ZEROUT^RADLY1 K RACCESS(DUZ,"DIV-IMG") W ! "RTN","RADLY",29,0) ASKLOG ; Ask log date "RTN","RADLY",30,0) W ! K %DT "RTN","RADLY",31,0) S %DT="PATEX",%DT("A")="Select Log Date: " "RTN","RADLY",32,0) S %DT("B")="T-1" D ^%DT K %DT "RTN","RADLY",33,0) I Y<0 D KILL^RADLY1 Q "RTN","RADLY",34,0) S RALDTI=Y\1 S RALDTX=$$FMTE^XLFDT(Y\1,1) "RTN","RADLY",35,0) S ZTDESC="Rad/Nuc Med Daily Log Rpt" "RTN","RADLY",36,0) S ZTRTN="START^RADLY",ZTSAVE("RALDT*")="" "RTN","RADLY",37,0) S ZTSAVE("^TMP($J,""RADLY"",")="",ZTSAVE("^TMP($J,""RA D-TYPE"",")="" "RTN","RADLY",38,0) S ZTSAVE("^TMP($J,""RA I-TYPE"",")="" "RTN","RADLY",39,0) S ZTSAVE("^TMP($J,""RA LOC-TYPE"",")="" "RTN","RADLY",40,0) D ZIS^RAUTL "RTN","RADLY",41,0) I RAPOP D KILL^RADLY1 Q "RTN","RADLY",42,0) START ; Start the process "RTN","RADLY",43,0) U IO D NOW^%DTC "RTN","RADLY",44,0) S:$D(ZTQUEUED) ZTREQ="@" "RTN","RADLY",45,0) S RATDY=$$FMTE^XLFDT(%\1,1),(RAPG,RAXIT)=0 "RTN","RADLY",46,0) S $P(RALN,"-",(IOM+1))="",RAHEAD="Daily Log Report For: "_RALDTX "RTN","RADLY",47,0) S RATAB(1)=$S(IOM=132:8,1:5),RATAB(2)=$S(IOM=132:25,1:8) "RTN","RADLY",48,0) S RATAB(3)=$S(IOM=132:42,1:25),RATAB(4)=$S(IOM=132:52,1:32) "RTN","RADLY",49,0) S RATAB(5)=$S(IOM=132:72,1:38),RATAB(6)=$S(IOM=132:95,1:43) "RTN","RADLY",50,0) S RATAB(7)=$S(IOM=132:114,1:60),RATAB(8)=$S(IOM=132:122,1:62) "RTN","RADLY",51,0) S RATAB(9)=$S(IOM=132:102,1:62) "RTN","RADLY",52,0) ; "RTN","RADLY",53,0) F RADTE=RALDTI:0 S RADTE=$O(^RADPT("AR",RADTE)) Q:'RADTE D Q:RAXIT "RTN","RADLY",54,0) . Q:RADTE>(RALDTI+.9999) "RTN","RADLY",55,0) . F RADFN=0:0 S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:'RADFN D Q:RAXIT "RTN","RADLY",56,0) .. S RADTI=9999999.9999-RADTE "RTN","RADLY",57,0) .. D:$D(^RADPT(RADFN,"DT",RADTI,0)) SORT^RADLY1 "RTN","RADLY",58,0) .. Q "RTN","RADLY",59,0) . Q "RTN","RADLY",60,0) I RAXIT D CLOSE^RAUTL,KILL^RADLY1 Q "RTN","RADLY",61,0) ; "RTN","RADLY",62,0) ; eliminate "RADLY" nodes that are outside the user-selected img locs "RTN","RADLY",63,0) N A,B,C S A="" "RTN","RADLY",64,0) CLN1 S A=$O(^TMP($J,"RADLY",A)) G:A']"" PREP S B="" "RTN","RADLY",65,0) CLN2 S B=$O(^TMP($J,"RADLY",A,B)) G:B']"" CLN1 S C="" "RTN","RADLY",66,0) CLN3 S C=$O(^TMP($J,"RADLY",A,B,C)) G:C']"" CLN2 "RTN","RADLY",67,0) K:$O(^TMP($J,"RA LOC-TYPE",C,0))="" ^TMP($J,"RADLY",A,B,C) "RTN","RADLY",68,0) K:$O(^TMP($J,"RA I-TYPE",B,0))="" ^TMP($J,"RADLY",A,B) "RTN","RADLY",69,0) K:$O(^TMP($J,"RADLY",A,""))="" ^TMP($J,"RADLY",A) "RTN","RADLY",70,0) G CLN3 "RTN","RADLY",71,0) PREP G:'$D(^TMP($J,"RADLY")) OUT "RTN","RADLY",72,0) S X=+$O(^TMP($J,"RADLY","")),Y=$O(^TMP($J,"RADLY",X,"")) "RTN","RADLY",73,0) S RADIV=$P($G(^DIC(4,X,0)),"^"),RAITYPE=Y "RTN","RADLY",74,0) S RAILOC=$O(^TMP($J,"RADLY",X,Y,"")) "RTN","RADLY",75,0) ; save current values "RTN","RADLY",76,0) S RADIV0=RADIV,RAITYPE0=RAITYPE,RAILOC0=RAILOC "RTN","RADLY",77,0) D HD^RADLY1 "RTN","RADLY",78,0) I RAXIT D CLOSE^RAUTL,KILL^RADLY1 Q "RTN","RADLY",79,0) I $D(^TMP($J,"RADLY")) D "RTN","RADLY",80,0) . D PRINT^RADLY1 ; Print out data "RTN","RADLY",81,0) . I 'RAXIT D "RTN","RADLY",82,0) .. S RADIVNM=$$DIVTOT^RACMP("RADLY") Q:'RADIVNM "RTN","RADLY",83,0) .. S (RADIV,RAFLG,RAITYPE)="",RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1 "RTN","RADLY",84,0) .. D:'RAXIT SYNOP "RTN","RADLY",85,0) .. Q "RTN","RADLY",86,0) . Q "RTN","RADLY",87,0) OUT D CLOSE^RAUTL,KILL^RADLY1 "RTN","RADLY",88,0) Q "RTN","RADLY",89,0) SET ; Set ^TMP global "RTN","RADLY",90,0) S RAEX(0)=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) "RTN","RADLY",91,0) S RACN=$P(RAEX(0),"^"),RAPRC=+$P(RAEX(0),"^",2) "RTN","RADLY",92,0) S RAPRC=$G(^RAMIS(71,RAPRC,0)),RAST=+$P(RAEX(0),"^",3) "RTN","RADLY",93,0) S RAPRC=$E($S(RAPRC]"":$P(RAPRC,"^"),1:"Unknown"),1,19) "RTN","RADLY",94,0) S RAST=$G(^RA(72,RAST,0)),RA6=+$P(RAEX(0),"^",6) "RTN","RADLY",95,0) S RA8=+$P(RAEX(0),"^",8),RA9=+$P(RAEX(0),"^",9) "RTN","RADLY",96,0) S RAST=$E($S(RAST]"":$P(RAST,"^"),1:"Unknown"),1,20) "RTN","RADLY",97,0) S X=RADTE D TIME^RAUTL1 S RATME=X "RTN","RADLY",98,0) S:$D(^DIC(42,RA6,0)) RAWHE=$P(^DIC(42,RA6,0),"^") "RTN","RADLY",99,0) S:$D(^SC(RA8,0)) RAWHE=$P(^SC(RA8,0),"^") "RTN","RADLY",100,0) S:$D(^DIC(34,RA9,0)) RAWHE=$P(^DIC(34,RA9,0),"^") "RTN","RADLY",101,0) S:$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"R")) RAWHE=$P(^("R"),"^") "RTN","RADLY",102,0) S RAWHE=$E($S($G(RAWHE)]"":RAWHE,1:"Unknown"),1,20) "RTN","RADLY",103,0) S RARPT=+$P(RAEX(0),"^",17) "RTN","RADLY",104,0) S RARPT=$S($O(^RARPT(RARPT,"R",0)):"Yes",1:"No") "RTN","RADLY",105,0) I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT "RTN","RADLY",106,0) S ^TMP($J,"RADLY",RADIV)=+$G(^TMP($J,"RADLY",RADIV))+1 "RTN","RADLY",107,0) S ^TMP($J,"RADLY",RADIV,RAITYPE)=+$G(^TMP($J,"RADLY",RADIV,RAITYPE))+1 "RTN","RADLY",108,0) S ^TMP($J,"RADLY",RADIV,RAITYPE,RAILOC)=+$G(^TMP($J,"RADLY",RADIV,RAITYPE,RAILOC))+1 "RTN","RADLY",109,0) S RADIVTY=+$G(RADIVTY)+1 "RTN","RADLY",110,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RADLY",111,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN) "RTN","RADLY",112,0) I $$USESSAN^RAHLRU1() S ^TMP($J,"RADLY",RADIV,RAITYPE,RAILOC,RANME,RADTE,RACNI)=RACNDSP_"^"_RAPRC_"^"_RAST_"^"_RATME_"^"_RAWHE_"^"_RARPT_"^"_RASSN "RTN","RADLY",113,0) I '$$USESSAN^RAHLRU1() S ^TMP($J,"RADLY",RADIV,RAITYPE,RAILOC,RANME,RADTE,RACNI)=RACN_"^"_RAPRC_"^"_RAST_"^"_RATME_"^"_RAWHE_"^"_RARPT_"^"_RASSN "RTN","RADLY",114,0) Q "RTN","RADLY",115,0) SYNOP ; Synopsis of data presented to the user. "RTN","RADLY",116,0) S A="" "RTN","RADLY",117,0) W !?RATAB(2),"Division",!?RATAB(2)+3,"Imaging Type",!?RATAB(2)+6,"Imaging Location(s)",! "RTN","RADLY",118,0) SYN1 S A=$O(^TMP($J,"RADLY",A)) Q:A']"" "RTN","RADLY",119,0) I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1 Q:RAXIT "RTN","RADLY",120,0) W !!?RATAB(2),$P($G(^DIC(4,A,0)),"^") S B="" "RTN","RADLY",121,0) SYN2 S B=$O(^TMP($J,"RADLY",A,B)) G:B']"" SYN1 "RTN","RADLY",122,0) I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1 Q:RAXIT "RTN","RADLY",123,0) W !?RATAB(2)+3,B,!?RATAB(2)+6 S C="" "RTN","RADLY",124,0) SYN3 S C=$O(^TMP($J,"RADLY",A,B,C)) G:C']"" SYN2 "RTN","RADLY",125,0) I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1 Q:RAXIT "RTN","RADLY",126,0) W:$X>(IOM-30) !?RATAB(2)+6 "RTN","RADLY",127,0) W C,?($X+3) "RTN","RADLY",128,0) G SYN3 "RTN","RADLY1") 0^33^B34932703 "RTN","RADLY1",1,0) RADLY1 ;HISC/GJC-Rad Daily Log Report ;5/7/97 13:50 "RTN","RADLY1",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21 "RTN","RADLY1",3,0) PRINT ; Output subroutine part one "RTN","RADLY1",4,0) S RA1="" "RTN","RADLY1",5,0) P1 S RA1=$O(^TMP($J,"RADLY",RA1)) Q:RA1']"" S RA2="" "RTN","RADLY1",6,0) S RADIV=$P($G(^DIC(4,RA1,0)),"^") D CKCHANGE Q:RAXIT "RTN","RADLY1",7,0) P2 S RA2=$O(^TMP($J,"RADLY",RA1,RA2)) I RA2']"" D DIVCHK Q:RAXIT G P1 "RTN","RADLY1",8,0) S RAITYPE=RA2,RA3="" D CKCHANGE Q:RAXIT "RTN","RADLY1",9,0) P3 S RA3=$O(^TMP($J,"RADLY",RA1,RA2,RA3)) I RA3']"" D IMGCHK Q:RAXIT G P2 "RTN","RADLY1",10,0) S RAILOC=RA3,RA4="" D CKCHANGE Q:RAXIT "RTN","RADLY1",11,0) P4 S RA4=$O(^TMP($J,"RADLY",RA1,RA2,RA3,RA4)) I RA4']"" D LOCCHK Q:RAXIT G P3 "RTN","RADLY1",12,0) S RA5="" "RTN","RADLY1",13,0) P5 S RA5=$O(^TMP($J,"RADLY",RA1,RA2,RA3,RA4,RA5)) G:RA5']"" P4 S RA6="" "RTN","RADLY1",14,0) P6 S RA6=$O(^TMP($J,"RADLY",RA1,RA2,RA3,RA4,RA5,RA6)) G:RA6']"" P5 S RA0=$G(^(RA6)) "RTN","RADLY1",15,0) D:RA0]"" PRT1 Q:RAXIT "RTN","RADLY1",16,0) G P6 "RTN","RADLY1",17,0) HD ; Header "RTN","RADLY1",18,0) W:RAPG!($E(IOST,1,2)="C-") @IOF "RTN","RADLY1",19,0) S RAPG=RAPG+1 W !?(IOM-$L(RAHEAD)\2-5),RAHEAD,?RATAB(9),"Page: ",RAPG "RTN","RADLY1",20,0) ; raflg gets set after all records are printed,=1 if more than 1 div. "RTN","RADLY1",21,0) W:'$D(RAFLG) !,"Division : ",$S(RADIV]"":RADIV,1:"Unknown") "RTN","RADLY1",22,0) W:$D(RAFLG) !,"Division : " "RTN","RADLY1",23,0) W ?RATAB(9),"Date: ",RATDY "RTN","RADLY1",24,0) N RA12 "RTN","RADLY1",25,0) S RA12=$S(RAILOC]"":RAILOC,1:"Unknown") "RTN","RADLY1",26,0) S:IOM<132 RA12=$E(RA12,1,30) "RTN","RADLY1",27,0) W:'$D(RAFLG) !,"Imaging Location : ",RA12," (" "RTN","RADLY1",28,0) W:$D(RAFLG) !,"Imaging Location :" "RTN","RADLY1",29,0) S RA12=$S(RAITYPE]"":RAITYPE,1:"Unknown") "RTN","RADLY1",30,0) S:IOM<132 RA12=$E(RA12,1,30) "RTN","RADLY1",31,0) W:'$D(RAFLG) RA12,")" "RTN","RADLY1",32,0) I IOM=132 D ; If 132 column "RTN","RADLY1",33,0) . I $$USESSAN^RAHLRU1() D "RTN","RADLY1",34,0) .. W !,"Name",?RATAB(2),"Pt ID",?RATAB(3)-2,"Time",?RATAB(4)-2 "RTN","RADLY1",35,0) .. W "Ward/Clinic",?RATAB(5)-1,"Procedure",?RATAB(6)-2,"Exam Status" "RTN","RADLY1",36,0) .. W ?RATAB(7)-4,"Case#",?RATAB(8)+6,"Rptd",!,RALN "RTN","RADLY1",37,0) . I '$$USESSAN^RAHLRU1() D "RTN","RADLY1",38,0) .. W !,"Name",?RATAB(2),"Pt ID",?RATAB(3),"Time",?RATAB(4),"Ward/Clinic" "RTN","RADLY1",39,0) .. W ?RATAB(5),"Procedure",?RATAB(6),"Exam Status",?RATAB(7),"Case#" "RTN","RADLY1",40,0) .. W ?RATAB(8),"Reported",!,RALN "RTN","RADLY1",41,0) . Q "RTN","RADLY1",42,0) E D ; default to 80 column format "RTN","RADLY1",43,0) . I $$USESSAN^RAHLRU1() D "RTN","RADLY1",44,0) .. W !,"Name",?RATAB(3),"Pt ID",?RATAB(5),"Ward/Clinic" "RTN","RADLY1",45,0) .. W ?RATAB(7),"Procedure",!,?RATAB(2),"Exam Status",?RATAB(4),"Case #" "RTN","RADLY1",46,0) .. W ?RATAB(6)+9,"Time",?RATAB(8)+8,"Reported",!,RALN "RTN","RADLY1",47,0) . I '$$USESSAN^RAHLRU1() D "RTN","RADLY1",48,0) .. W !,"Name",?RATAB(3),"Pt ID",?RATAB(5),"Ward/Clinic" "RTN","RADLY1",49,0) .. W ?RATAB(7),"Procedure",!,?RATAB(2),"Exam Status",?RATAB(4),"Case #" "RTN","RADLY1",50,0) .. W ?RATAB(6),"Time",?RATAB(8),"Reported",!,RALN "RTN","RADLY1",51,0) . Q "RTN","RADLY1",52,0) I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 "RTN","RADLY1",53,0) Q "RTN","RADLY1",54,0) PRT1 ; Output subroutine two "RTN","RADLY1",55,0) F I=1:1:7 D "RTN","RADLY1",56,0) . S @$P("RACN^RAPRC^RAST^RATME^RAWHE^RARPT^RASSN","^",I)=$P(RA0,"^",I) "RTN","RADLY1",57,0) . Q "RTN","RADLY1",58,0) I $Y>(IOSL-4) D Q:RAXIT "RTN","RADLY1",59,0) . S:$E(IOST,1,2)="C-" RAXIT=$$EOS^RAUTL5() D:'RAXIT HD "RTN","RADLY1",60,0) . Q "RTN","RADLY1",61,0) I IOM=132 D ; default to 132 column format "RTN","RADLY1",62,0) . I $$USESSAN^RAHLRU1() D "RTN","RADLY1",63,0) .. W !,RA4,?RATAB(2),RASSN,?RATAB(3)-2,RATME,?RATAB(4)-2,RAWHE "RTN","RADLY1",64,0) .. W ?RATAB(5)-1,RAPRC,?RATAB(6)-2,$E(RAST,1,14),?RATAB(7)-4,RACN "RTN","RADLY1",65,0) .. W ?RATAB(8)+6,RARPT "RTN","RADLY1",66,0) . I '$$USESSAN^RAHLRU1() D "RTN","RADLY1",67,0) .. W !,RA4,?RATAB(2),RASSN,?RATAB(3),RATME,?RATAB(4),RAWHE "RTN","RADLY1",68,0) .. W ?RATAB(5),RAPRC,?RATAB(6),RAST,?RATAB(7),RACN,?RATAB(8),RARPT "RTN","RADLY1",69,0) . Q "RTN","RADLY1",70,0) E D ; If 80 column "RTN","RADLY1",71,0) . I $$USESSAN^RAHLRU1() D "RTN","RADLY1",72,0) .. W !,RA4,?RATAB(3),RASSN,?RATAB(5),RAWHE,?RATAB(7),RAPRC,!?RATAB(2) "RTN","RADLY1",73,0) .. W RAST,?RATAB(4),RACN,?RATAB(6)+9,RATME,?RATAB(8)+8,RARPT "RTN","RADLY1",74,0) . I '$$USESSAN^RAHLRU1() D "RTN","RADLY1",75,0) .. W !,RA4,?RATAB(3),RASSN,?RATAB(5),RAWHE,?RATAB(7),RAPRC "RTN","RADLY1",76,0) .. W !?RATAB(2),RAST,?RATAB(4),RACN,?RATAB(6),RATME,?RATAB(8),RARPT "RTN","RADLY1",77,0) . Q "RTN","RADLY1",78,0) Q "RTN","RADLY1",79,0) KILL ; Kill variables "RTN","RADLY1",80,0) K %,%I,%X,%Y,DIC,I,RA0,RA1,RA2,RA3,RA4,RA5,RA6,RA7,RA8,RA9,RA10,RA11 "RTN","RADLY1",81,0) K RACN,RACNI,RADFN,RADIV,RADIVNM,RADIVTY,RADTE,RADTI,RAEX,RAFLG,RAHEAD "RTN","RADLY1",82,0) K RAIMGTY,RAITYPE,RALDTI,RALDTX,RALN,RAMES,RANME,RAPG,RAPOP,RAPRC,RAPT "RTN","RADLY1",83,0) K RAQUIT,RARE,RARPT,RASSN,RAST,RATAB,RATDY,RATME,RAWHE,RAXIT,X,Y,ZTDESC "RTN","RADLY1",84,0) K RAILOC,RADIV0,RAITYPE0,RAILOC0 "RTN","RADLY1",85,0) K ZTRTN,ZTSAVE K:$D(RAPSTX) RACCESS,RAPSTX,POP,DUOUT "RTN","RADLY1",86,0) K ^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE"),^TMP($J,"RADLY") "RTN","RADLY1",87,0) K ^TMP($J,"RA LOC-TYPE"),^TMP($J,"DIV-ITYP-ILOC") "RTN","RADLY1",88,0) Q "RTN","RADLY1",89,0) DIVCHK ; Output statistics within division. "RTN","RADLY1",90,0) N RA7 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD Q:RAXIT "RTN","RADLY1",91,0) W !?RATAB(2),"Division Total '"_RADIV_"': ",+$G(^TMP($J,"RADLY",RA1)) "RTN","RADLY1",92,0) Q "RTN","RADLY1",93,0) IMGCHK ; Check for EOS on I-Type "RTN","RADLY1",94,0) N RA10 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD Q:RAXIT "RTN","RADLY1",95,0) W !?RATAB(2),"Imaging Type Total '"_RAITYPE_"': ",+$G(^TMP($J,"RADLY",RA1,RAITYPE)) "RTN","RADLY1",96,0) Q "RTN","RADLY1",97,0) LOCCHK ; Check for EOS on Loc-Type "RTN","RADLY1",98,0) N RA9 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD Q:RAXIT "RTN","RADLY1",99,0) W !?RATAB(2),"Imaging Location Total '"_RAILOC_"': ",+$G(^TMP($J,"RADLY",RA1,RAITYPE,RAILOC)) "RTN","RADLY1",100,0) Q "RTN","RADLY1",101,0) CKCHANGE ; Check for change in div/img-type/img-loc, for header "RTN","RADLY1",102,0) N A,RAPRTHD "RTN","RADLY1",103,0) S RAPRTHD=0 ;whether to print page header or not, 1=yes "RTN","RADLY1",104,0) S A=$P($G(^DIC(4,+RA1,0)),"^") "RTN","RADLY1",105,0) I $G(RA2)]"",$G(RA3)]"" S:A'=RADIV0 RAPRTHD=1 "RTN","RADLY1",106,0) I $G(RA2)]"",$G(RA3)]"",RADIV0=A S:RA2'=RAITYPE0 RAPRTHD=1 "RTN","RADLY1",107,0) I $G(RA3)]"",RAITYPE0=RA2 S:RA3'=RAILOC0 RAPRTHD=1 "RTN","RADLY1",108,0) S RADIV0=A S:$G(RA2)]"" RAITYPE0=RA2 S:$G(RA3)]"" RAILOC0=RA3 "RTN","RADLY1",109,0) Q:'RAPRTHD&($Y<(IOSL-5)) "RTN","RADLY1",110,0) S:$E(IOST,1,2)="C-" RAXIT=$$EOS^RAUTL5() "RTN","RADLY1",111,0) D:'RAXIT HD "RTN","RADLY1",112,0) Q "RTN","RADLY1",113,0) SORT ; Gather/sort data "RTN","RADLY1",114,0) S RARE(0)=$G(^RADPT(RADFN,"DT",RADTI,0)) "RTN","RADLY1",115,0) S RADIV=+$P(RARE(0),"^",3),RADIV("I")=+$P($G(^RA(79,RADIV,0)),"^") "RTN","RADLY1",116,0) S RADIV=$P($G(^DIC(4,RADIV("I"),0)),"^") "RTN","RADLY1",117,0) I RADIV']""!('$D(^TMP($J,"RA D-TYPE",RADIV))) Q ; no div "RTN","RADLY1",118,0) S RADIV=RADIV("I") K RADIV("I") "RTN","RADLY1",119,0) S RAITYPE=+$P(RARE(0),"^",2) Q:RAITYPE'>0 "RTN","RADLY1",120,0) S RAITYPE=$P($G(^RA(79.2,RAITYPE,0)),"^") "RTN","RADLY1",121,0) Q:'$D(^TMP($J,"RA I-TYPE",RAITYPE)) ; no img type "RTN","RADLY1",122,0) S RAILOC=+$P(RARE(0),"^",4) Q:RAILOC'>0 "RTN","RADLY1",123,0) S RAILOC=$P($G(^RA(79.1,RAILOC,0)),"^"),RAILOC=$P($G(^SC(+RAILOC,0)),"^") "RTN","RADLY1",124,0) Q:'$D(^TMP($J,"RA LOC-TYPE",RAILOC)) ;no img loc "RTN","RADLY1",125,0) S (RANME,RASSN)="Unknown",RAPT(0)=$G(^DPT(RADFN,0)) "RTN","RADLY1",126,0) S RANME=$S($P(RAPT(0),"^")]"":$P(RAPT(0),"^"),1:RANME) "RTN","RADLY1",127,0) S RASSN=$$SSN^RAUTL,RANME=$E(RANME,1,23) "RTN","RADLY1",128,0) F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI D Q:RAXIT "RTN","RADLY1",129,0) . D:$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) SET^RADLY "RTN","RADLY1",130,0) . Q "RTN","RADLY1",131,0) Q "RTN","RADLY1",132,0) ZEROUT ; zero out the ^tmp($j,"RADLY" "RTN","RADLY1",133,0) ; loop throu raccess(duz,"DIV,ITYP-ILOC",divname,imgtypename,imglocname) "RTN","RADLY1",134,0) ; THIS SECTION REPLACES THE ORIGINAL CALL TO ZEROUT^RADLQ3("RADLY") "RTN","RADLY1",135,0) ; so to ensure that locations not assigned to the user will be "RTN","RADLY1",136,0) ; zeroed out, if those locations share the same imaging types that "RTN","RADLY1",137,0) ; his assigned locations have "RTN","RADLY1",138,0) N X,Y,Z,X1 "RTN","RADLY1",139,0) S X="" "RTN","RADLY1",140,0) ZER1 S X=$O(RACCESS(DUZ,"DIV-ITYP-ILOC",X)) Q:X="" ;eg. "cgo (ws)" "RTN","RADLY1",141,0) S Y="",X1=$O(^DIC(4,"B",X,0)) ; eg. 639 "RTN","RADLY1",142,0) ZER2 S Y=$O(RACCESS(DUZ,"DIV-ITYP-ILOC",X,Y)) G:Y="" ZER1 S Z="" ;eg. "gen rad" "RTN","RADLY1",143,0) ZER3 S Z=$O(RACCESS(DUZ,"DIV-ITYP-ILOC",X,Y,Z)) G:Z="" ZER2 ;eg. "x-ray" "RTN","RADLY1",144,0) S ^TMP($J,"RADLY",X1,Y,Z)=0 "RTN","RADLY1",145,0) G ZER3 "RTN","RAEDPT") 0^34^B10329969 "RTN","RAEDPT",1,0) RAEDPT ;HISC/FPT,GJC,SS AISC/MJK,RMO-Edit Exams by Patient ;4/21/97 10:47 "RTN","RAEDPT",2,0) ;;5.0;Radiology/Nuclear Medicine;**10,18,28,45,47**;Mar 16, 1998;Build 21 "RTN","RAEDPT",3,0) ;last modification by SS JUNE 19,2000 "RTN","RAEDPT",4,0) CASE D SET^RAPSET1 I $D(XQUIT) K XQUIT,POP Q "RTN","RAEDPT",5,0) S RAXIT=0,DIC(0)="AEMQ" D ^RADPA G Q:Y<0 "RTN","RAEDPT",6,0) S RADFN=+Y,RAHEAD="**** Edit Exams By Patient ****" "RTN","RAEDPT",7,0) D ^RAPTLU G CASE:"^"[X "RTN","RAEDPT",8,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RAEDPT",9,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN) "RTN","RAEDPT",10,0) I $$USESSAN^RAHLRU1() W !!?5,"Case No.: ",RACNDSP,!?4,"Procedure: ",$E(RAPRC,1,30),?56,"Date: ",RADATE "RTN","RAEDPT",11,0) I '$$USESSAN^RAHLRU1() W !!,"Case No.:",RACN,?15,"Procedure:",$E(RAPRC,1,30),?57,"Date:",RADATE "RTN","RAEDPT",12,0) N RADISPLY "RTN","RAEDPT",13,0) S RADISPLY=$G(^RAMIS(71,+$P($G(^RADPT(+RADFN,"DT",+RADTI,"P",+RACNI,0)),U,2),0)) ; set $ZR to 71 for prccpt^radd1, not call raprod since diff col "RTN","RAEDPT",14,0) S RADISPLY=$$PRCCPT^RADD1() "RTN","RAEDPT",15,0) W !,?25,RADISPLY "RTN","RAEDPT",16,0) I $D(^RA(72,"AA",RAIMGTY,9,+RAST)),'$D(^XUSEC("RA MGR",DUZ)) W !!?3,$C(7),"You do not have the appropriate access privilege to edit completed exams.",! G CASE "RTN","RAEDPT",17,0) I $D(^RA(72,"AA",RAIMGTY,0,+RAST)) W !!?3,$C(7),"Exam has been 'cancelled' therefore it cannot be edited." G CASE "RTN","RAEDPT",18,0) S RAQUICK=0,DA=RADFN,DIE("NO^")="OUTOK" "RTN","RAEDPT",19,0) S RADADA=RADTI ; RADTI defined in ^RAPTLU "RTN","RAEDPT",20,0) S DIE="^RADPT(",DR="[RA EXAM EDIT]" "RTN","RAEDPT",21,0) S RADIE="^RADPT("_RADFN_",""DT""," "RTN","RAEDPT",22,0) S RAXIT=$$LOCK^RAUTL12(RADIE,RADADA) I RAXIT G CASE "RTN","RAEDPT",23,0) N RAREM,RANUZD1,RAPSDRUG,RA00,RADIOPH,RALOW,RAHI,RADRAWN,RAASK,RADOSE,RASKMEDS,RAWHICH ;these are used by the edit template "RTN","RAEDPT",24,0) ; "RTN","RAEDPT",25,0) ;save 'before' CM data value to compare against the possible 'after' "RTN","RAEDPT",26,0) ;value "RTN","RAEDPT",27,0) D TRK70CMB^RAMAINU(RADFN,RADTI,RACNI,.RATRKCMB) ;RA*5*45 "RTN","RAEDPT",28,0) ; "RTN","RAEDPT",29,0) D SVBEFOR^RAO7XX(RADFN,RADTI,RACNI) ;P18 save before edit to compare later in RAUTL1 "RTN","RAEDPT",30,0) D ^DIE K DE,DQ,DIE,DR,RAZCM "RTN","RAEDPT",31,0) S:$D(RAPRI) RAPRIT=RAPRI D UP1^RAUTL1 "RTN","RAEDPT",32,0) ; "RTN","RAEDPT",33,0) ;1) check data consistency between 'CONTRAST MEDIA USED' & 'CONTRAST "RTN","RAEDPT",34,0) ;MEDIA' "RTN","RAEDPT",35,0) ;2) check 'before' CM data against 'after' CM data, file in audit log "RTN","RAEDPT",36,0) ;if necessary. Remember, contrast media asked when in input template: "RTN","RAEDPT",37,0) ;RA EXAM EDIT (RA*5*45) "RTN","RAEDPT",38,0) S RACMDA=RACNI,RACMDA(1)=RADTI,RACMDA(2)=RADFN "RTN","RAEDPT",39,0) D XCMINTEG^RAMAINU1(.RACMDA) ;1 "RTN","RAEDPT",40,0) D TRK70CMA^RAMAINU(RADFN,RADTI,RACNI,RATRKCMB) ;2 "RTN","RAEDPT",41,0) K RACMDA "RTN","RAEDPT",42,0) ; "RTN","RAEDPT",43,0) D UNLOCK^RAUTL12(RADIE,RADADA) ;modif P18 by SS "RTN","RAEDPT",44,0) K RATRKCMB,RADADA,RADIE,RADUZ W ! G CASE ;modif P18 by SS "RTN","RAEDPT",45,0) ; "RTN","RAEDPT",46,0) Q K %,%DT,%Y,A,C,D0,D1,D2,DA,DIC,I,RACN,RACNI,RACNT,RACT,RADADA,RADATE,RADATI,RADFN,RADIE,RADTE,RADTI,RAHEAD,RAMES,RANME,RAOR,RAORDIFN,RAPOP,RAPRC,RAPRI,RAQUICK,RARPT,RASN,RASSN,RAST,RASTI,RAXIT,XQUIT,VAINDT,VADMVT,X,Y "RTN","RAEDPT",47,0) K ^TMP($J,"RAEX") "RTN","RAEDPT",48,0) K %W,%Y1,D,D3,DDER,DI,DK,DL,POP,DISYS,DUOUT,RAI "RTN","RAEDPT",49,0) Q "RTN","RAESO") 0^35^B27993971 "RTN","RAESO",1,0) RAESO ;HISC/CAH,GJC AISC/SAW-Override Exam Status to Complete ;4/28/97 08:00 "RTN","RAESO",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21 "RTN","RAESO",3,0) ;Mass override exam status to complete "RTN","RAESO",4,0) D SET^RAPSET1 I $D(XQUIT) K XQUIT,POP Q "RTN","RAESO",5,0) N RAXIT,RASAVDR S RAXIT=0 D CZECH Q:RAXIT "RTN","RAESO",6,0) W !,"Your sign-on imaging type is ",RAIMGTY,", so only exams",!,"of imaging type ",RAIMGTY," will be changed to complete.",! "RTN","RAESO",7,0) K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to proceed" D ^DIR I Y'=1 G EXIT "RTN","RAESO",8,0) K DIR,X,Y "RTN","RAESO",9,0) ASK K DIC S DIC(0)="AEQM",DIC="^RA(72," "RTN","RAESO",10,0) S DIC("S")="I $P(^(0),U,3)'=9,($P(^(0),U,3)'=0),($P(^(0),U,7)=+$O(^RA(79.2,""B"",RAIMGTY,0)))" "RTN","RAESO",11,0) D ^DIC G EXIT:$D(DUOUT)!($D(DTOUT)) I Y'<0 S RASTIEN(+Y)="" G ASK "RTN","RAESO",12,0) G EXIT:'$D(RASTIEN) K DIC W !!,"Enter a cutoff date that is at least sixty days prior to today." "RTN","RAESO",13,0) S X1=DT,X2=-60 D C^%DTC S DIR(0)="D^:"_X D ^DIR G EXIT:$D(DIRUT) S RAECDTI=9999999-Y D DD^%DT S RAECDTE=Y "RTN","RAESO",14,0) ;Following line commented out for v 4.5 - setting the 10th piece to 0 was preventing update of subfld 75, Exam Status Times. These are now updated. "RTN","RAESO",15,0) W ! S IOP="Q",ZTRTN="DQ^RAESO" "RTN","RAESO",16,0) S ZTSAVE("RAI*")="",ZTSAVE("RAM*")="",ZTSAVE("RAE*")="" "RTN","RAESO",17,0) S ZTSAVE("RASTIEN(")="" "RTN","RAESO",18,0) S ZTDESC="Rad/Nuc Med Mass Override of Exam Status to Complete",RAMES="W !,?5,""Output Queued.""",RAZIS=1 D ZIS^RAUTL K IOP "RTN","RAESO",19,0) G EXIT "RTN","RAESO",20,0) DQ U IO S PG=0 S RAIMGTYI=$O(^RA(79.2,"B",RAIMGTY,0)) "RTN","RAESO",21,0) F RAST=0:0 S RAST=$O(RASTIEN(RAST)) Q:RAST'>0 F RADFN=0:0 S RADFN=$O(^RADPT("AS",RAST,RADFN)) Q:RADFN'>0 F RADTI=RAECDTI:0 S RADTI=$O(^RADPT("AS",RAST,RADFN,RADTI)) Q:RADTI'>0 D L1 "RTN","RAESO",22,0) I '$D(RAF4) D HD W !!,"There were no exams with the statuses selected in the time frame specified that",!,"needed to be overridden to complete." "RTN","RAESO",23,0) EXIT D CLOSE^RAUTL "RTN","RAESO",24,0) K DA,DIC,DIE,DIR,DIRUT,DIROUT,DUOUT,DTOUT,DR,PG,POP "RTN","RAESO",25,0) K RA,RACN,RACNI,RADFN,RADTE,RADTI,RAECDTE,RAECDTI,RAF1,RAF4,RAIMGTYI,RAMES,RAPOP,RAST,RASTIEN,RAZMDV,RAZIS "RTN","RAESO",26,0) K X,X1,X2,XQUIT,Y,ZTDESC,ZTRTN,ZTSAVE,I,POP,DISYS,C Q "RTN","RAESO",27,0) L1 F RACNI=0:0 S RACNI=$O(^RADPT("AS",RAST,RADFN,RADTI,RACNI)) Q:RACNI'>0 I $P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2)=RAIMGTYI I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S RA(0)=^(0) D SET "RTN","RAESO",28,0) Q "RTN","RAESO",29,0) SET S RACN=$P(RA(0),"^"),RADTE=9999999.9999-RADTI,DA=RADFN,DIE="^RADPT(",DR="[RA OVERRIDE]",RASAVDR=DR D ^DIE K DE,DQ,DIE,DR "RTN","RAESO",30,0) D:'$D(RAF1) HD D:$Y-(IOSL-11)>0 HD W !,$E($P(^DPT(RADFN,0),"^"),1,25),?28 S Y=RADTE D DD^%DT W Y,?49,RACN,?57,$S($D(^RA(72,RAST,0)):$E($P(^(0),"^"),1,20),1:"Unknown") S RAF4=1 "RTN","RAESO",31,0) D ^RAORDC Q "RTN","RAESO",32,0) HD S PG=PG+1 W:$Y>0 @IOF,!!,?(IOM\2-26),"Report on Mass Override of Exam Statuses to Complete",?(IOM-8),"PAGE ",PG "RTN","RAESO",33,0) W !,?(IOM\2-22),"Cutoff Date for this Report is: ",RAECDTE,!,?(IOM\2-17),"Date Report was Run: " S Y=DT D DD^%DT W Y "RTN","RAESO",34,0) W !!!,"Patient Name",?28,"Exam Date",?49,"Case #",?57,"Status Before Override",! S RAF1=1 Q "RTN","RAESO",35,0) SINGLE ;Override Single Exam Status to 'COMPLETE' "RTN","RAESO",36,0) D SET^RAPSET1 I $D(XQUIT) K XQUIT Q "RTN","RAESO",37,0) N RAXIT,RASAVDR S RAXIT=0 D CZECH Q:RAXIT "RTN","RAESO",38,0) S RAVW="" D ^RACNLU G EXIT1:"^"[X W ! S I="",$P(I,"-",80)="" W I "RTN","RAESO",39,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RAESO",40,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN) "RTN","RAESO",41,0) I $$USESSAN^RAHLRU1() W !?1,"Name : ",$E(RANME,1,25),?40,"Pt ID : ",RASSN,!?1,"Case No. : ",RACNDSP,?40,"Procedure : ",$E(RAPRC,1,25) "RTN","RAESO",42,0) I '$$USESSAN^RAHLRU1() W !?1,"Name : ",$E(RANME,1,25),?40,"Pt ID : ",RASSN,!?1,"Case No. : ",RACN,?40,"Procedure : ",$E(RAPRC,1,25) "RTN","RAESO",43,0) W !?1,"Exam Date: ",RADATE,?40,"Technologist: " I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0))>0,$D(^VA(200,+^($O(^(0)),0),0)) W $E($P(^(0),"^"),1,25) "RTN","RAESO",44,0) W !?40,"Req Phys : ",$E($S($D(^VA(200,+$P(Y(0),"^",14),0)):$P(^(0),"^"),1:""),1,25),! S I="",$P(I,"-",80)="" W I "RTN","RAESO",45,0) I $P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2)'=$O(^RA(79.2,"B",RAIMGTY,0)) W !,"Sorry, your sign-on imaging type, ",RAIMGTY,!,"doesn't match the imaging type of this exam.",! G SINGLE "RTN","RAESO",46,0) I $D(^RA(72,"AA",RAIMGTY,0,+RAST)) W !!?3,*7,"...exam 'cancelled' therefore override is not allowed." G SINGLE "RTN","RAESO",47,0) I $D(^RA(72,"AA",RAIMGTY,9,+RAST)) W !!?3,*7,"...exam is already 'complete'." G SINGLE "RTN","RAESO",48,0) ASKOVR R !!,"Are you sure? No// ",X:DTIME S:'$T!(X="")!(X["^") X="N" G SINGLE:"Nn"[$E(X) I "Yy"'[$E(X) W:X'["?" *7 W !!?3,"Enter 'YES' to override exam status to 'COMPLETE', or 'NO' not to." G ASKOVR "RTN","RAESO",49,0) W !?3,"...will now attempt override..." S DA=RADFN,DIE="^RADPT(",DR="[RA OVERRIDE]",RASAVDR=DR D ^DIE K DE,DQ,DIE,DR I '$D(Y) W !?6,"...exam status is now '",$P(^RA(72,$O(^RA(72,"AA",RAIMGTY,9,0)),0),"^"),"'.",! D ^RAORDC K DR "RTN","RAESO",50,0) G SINGLE "RTN","RAESO",51,0) EXIT1 K %,%DT,%I,%X,%Y,D,D0,D1,D2,D3,DA,DI,DIC,J,POP,RADFN,RADIV,RADTI,RACNI "RTN","RAESO",52,0) K RANME,RASSN,RADATE,RADTE,RACN,RAHEAD,RAI,RAPRC,RAPIFN,RARPT,RAST,RAVW "RTN","RAESO",53,0) K W,X,XQUIT,Y,^TMP($J,"RAEX") "RTN","RAESO",54,0) Q "RTN","RAESO",55,0) CZECH ; Check for a 'Complete' exam status for a particular imaging type "RTN","RAESO",56,0) I '+$O(^RA(72,"AA",RAIMGTY,9,0)) D "RTN","RAESO",57,0) . S RAXIT=1 "RTN","RAESO",58,0) . W !?5,"An Examination Status of 'Complete' must be defined for an" "RTN","RAESO",59,0) . W !?5,"Imaging Type of: "_RAIMGTY_". Please contact your" "RTN","RAESO",60,0) . W !?5,"Radiology/Nuclear Medicine ADPAC for further assistance.",$C(7) "RTN","RAESO",61,0) . Q "RTN","RAESO",62,0) Q "RTN","RAFLH") 0^36^B23566413 "RTN","RAFLH",1,0) RAFLH ;HISC/FPT AISC/MJK-Print Radiology Flash Cards ;12/4/97 12:25 "RTN","RAFLH",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21 "RTN","RAFLH",3,0) 1 Q:'$D(^RADPT(RADFN,0)) S RAY1=^(0) Q:'$D(^DPT(RADFN,0)) S RAY0=^(0) "RTN","RAFLH",4,0) Q:'$D(^RADPT(RADFN,"DT",RADTI,0)) S RAY2=^(0) "RTN","RAFLH",5,0) ; "RTN","RAFLH",6,0) I $D(ZTQUEUED) S ZTREQ="@" "RTN","RAFLH",7,0) I RAFLHFL S RACNI=RAFLHFL Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S RAY3=^(0),X=$S($D(^RAMIS(71,+$P(RAY3,"^",2),0)):^(0),1:"") D RAFMT,PRT G EXIT "RTN","RAFLH",8,0) ; pce 2 of RAFLHFL, is set only if 'Add Exams to Last Visit', "RTN","RAFLH",9,0) ; so that loop is done only thru newly added exams "RTN","RAFLH",10,0) F RACNI=+$P(RAFLHFL,";",2):0 S RAFMT=RAFLH,RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0!($D(RANUMF)) I $D(^(RACNI,0)) S RAY3=^(0),X=$S($D(^RAMIS(71,+$P(RAY3,"^",2),0)):^(0),1:"") D RAFMT D CASE "RTN","RAFLH",11,0) EXIT D ^RAFLH1,Q^RAFLH1 Q "RTN","RAFLH",12,0) CASE K RAX S RAFL=$S($P(X,"^",3)="":1,'$D(^%ZIS(1,+$P(X,"^",3),0)):1,1:0) Q:'RAFL "RTN","RAFLH",13,0) ; if $D(RADIF) and using img loc's 'how many flash cards each visit', "RTN","RAFLH",14,0) ; then RAVISIT1 is ignored, which may result in extra flash cards "RTN","RAFLH",15,0) I RAFLHFL["ALL"!($D(RADIF)) D PRT Q "RTN","RAFLH",16,0) ; RAVISIT1 defined if img loc param specifies exactly how many "RTN","RAFLH",17,0) ; flash cards should print per visit (and div param is 'no') . "RTN","RAFLH",18,0) ; When exactly that many cards have been printed, RANUMF is defined. "RTN","RAFLH",19,0) D PRT S:$D(RAVISIT1) RANUMF=1 "RTN","RAFLH",20,0) Q "RTN","RAFLH",21,0) ; "RTN","RAFLH",22,0) RAFMT K RADIF S RAFMT=$S($P(X,"^",4):$P(X,"^",4),1:RAFLH) S:RAFMT'=RAFLH RADIF="" Q "RTN","RAFLH",23,0) ; "RTN","RAFLH",24,0) PRT I '$D(^RA(78.2,RAFMT,0)) W @$S($G(RAFFLF)]"":RAFFLF,1:IOF) Q "RTN","RAFLH",25,0) N RACNT,RAIND1,RAIND2 D PSET^%ZISP "RTN","RAFLH",26,0) N RAMEMLOW,RAPRTSET,RAEXSPEC,RAVAL "RTN","RAFLH",27,0) D EN1^RAUTL20 "RTN","RAFLH",28,0) ; RAEXSPEC = array to store print fld that's exam specific "RTN","RAFLH",29,0) I '$D(RATEST) D "RTN","RAFLH",30,0) .;RAY=data dict: 78.21; fld: .01 (ptr to a file 78.7 record) "RTN","RAFLH",31,0) .;RAX=zero node of the file 78.7 record "RTN","RAFLH",32,0) .N RAY S RAI=0 "RTN","RAFLH",33,0) .F S RAI=$O(^RA(78.2,RAFMT,1,RAI)) Q:RAI'>0 D "RTN","RAFLH",34,0) ..S RAY=+$P($G(^RA(78.2,RAFMT,1,RAI,0)),U) Q:'($D(^RA(78.7,RAY,"E"))#2) "RTN","RAFLH",35,0) ..X ^RA(78.7,RAY,"E") ;w/P47 "RTN","RAFLH",36,0) ..I $P(^RA(78.7,RAY,0),U,6)="Y",$P(^(0),U,5)]"" S RAEXSPEC($P(^(0),U,5))=1 "RTN","RAFLH",37,0) ..Q "RTN","RAFLH",38,0) .Q "RTN","RAFLH",39,0) ;RANUM = # of jacket labels to print (user defined) RA LABELS - Jacket Labels (RAJAC) "RTN","RAFLH",40,0) F RAII=1:1:RANUM D "RTN","RAFLH",41,0) . S RAI=0 F S RAI=$O(^RA(78.2,RAFMT,"E",RAI)) Q:RAI'>0 D "RTN","RAFLH",42,0) .. I $G(^RA(78.2,RAFMT,"E",RAI,0))'["@" D "RTN","RAFLH",43,0) ... ; P47 add new SSAN vars: RACNDSP "RTN","RAFLH",44,0) ... N RASSAN,RACSESAV,RACNDSP S RASSAN="" "RTN","RAFLH",45,0) ... I $D(RADFN),$D(RADTI),$D(RACNI) S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RAFLH",46,0) ... S RACNDSP=$S((RASSAN'=""):RASSAN,1:$G(RACSE)) "RTN","RAFLH",47,0) ... I $$USESSAN^RAHLRU1() S RACSESAV=$G(RACSE),RACSE=RACNDSP "RTN","RAFLH",48,0) ... X ^RA(78.2,RAFMT,"E",RAI,0) "RTN","RAFLH",49,0) ... I $$USESSAN^RAHLRU1() S RACSE=RACSESAV "RTN","RAFLH",50,0) ... S RAVAL=$P(^RA(78.2,RAFMT,"E",RAI,0),",RA",2) S:RAVAL]"" RAVAL="RA"_RAVAL "RTN","RAFLH",51,0) ... I RAVAL]"",@RAVAL]"",$G(RAEXSPEC(RAVAL)),RAPRTSET W "+" "RTN","RAFLH",52,0) ... Q "RTN","RAFLH",53,0) .. E D XECFLH^RAFLH2(RAFMT,RAI) "RTN","RAFLH",54,0) .. Q "RTN","RAFLH",55,0) . I $G(RAFMT)=$G(RAHDFM) Q "RTN","RAFLH",56,0) . W @$S($G(RAFFLF)]"":RAFFLF,1:IOF) "RTN","RAFLH",57,0) . Q "RTN","RAFLH",58,0) D PKILL^%ZISP K RAI,RAII "RTN","RAFLH",59,0) Q "RTN","RAFLH",60,0) ; "RTN","RAFLH",61,0) FLH ; Flash card entry point. "RTN","RAFLH",62,0) N RAPRNT S RAPRNT=$$PRINT^RAFLH2(RAMDIV,RAMLC,.RAPX) Q:'RAPRNT "RTN","RAFLH",63,0) ; from orig. devlprs -- if NO default flashcard format, set RAFLH to 1 "RTN","RAFLH",64,0) S (RAEXFM,RAEXLBLS)=0,RANUM=1,RAFLH=$S($P(RAMLC,"^",7):$P(RAMLC,"^",7),1:1) "RTN","RAFLH",65,0) K RAFLHCNT "RTN","RAFLH",66,0) F I=0:0 S I=$O(RAPX(I)) Q:I'>0 S RAFLHCNT(I)="" "RTN","RAFLH",67,0) ; Print a flash card for each proc whose 'Required Flash Card Printer' "RTN","RAFLH",68,0) ; field contains a valid printer regardless of other loc and div params "RTN","RAFLH",69,0) ; For each card printed, its corresponding RAFLHCNT(I) is deleted. "RTN","RAFLH",70,0) ; Any RAFLHCNT() left would mean continuing on to paragragh 1 "RTN","RAFLH",71,0) F I=0:0 S I=$O(RAPX(I)) Q:I'>0 I $P(RAPX(I),"^",4)]"",$D(^%ZIS(1,+$P(RAPX(I),"^",4),0)) S ION=$P(^(0),"^"),IOP=$S(ION]"":"Q;"_ION,1:"Q"),RAFLHFL=I D D Q "RTN","RAFLH",72,0) .S RAMES="W !!?3,""NOTE: Case No. "",$P(RAPX(I),""^""),"" ("",$E($P(RAPX(I),""^"",2),1,20),"") has been queued to printer "",ION,""."",!" "RTN","RAFLH",73,0) .S RAMESCNT=$G(RAMESCNT)+1 "RTN","RAFLH",74,0) .K RAFLHCNT(I) "RTN","RAFLH",75,0) S RAMES="W !?5,""...all needed flash cards and exam labels queued to print on "",ION,""."",!" "RTN","RAFLH",76,0) ; known problem inheritied : "RTN","RAFLH",77,0) ; when all flash cards have been printed because all the procedures "RTN","RAFLH",78,0) ; had REQUIRED FLASH CARD PRINTER defined, then the following msg "RTN","RAFLH",79,0) ; should not print, but as inherited, it does "RTN","RAFLH",80,0) S:$D(RAMESCNT) RAMES="W !?5,""...all remaining flash cards and exam labels queued to print on "",ION,""."",!" "RTN","RAFLH",81,0) K RAMESCNT S ION=$P(RAMLC,"^",3),IOP=$S(ION]"":"Q;"_ION,1:"Q") "RTN","RAFLH",82,0) I IOP="Q" S RASELDEV="Select the FLASH CARD/EXAM LABEL Printer" "RTN","RAFLH",83,0) ; RAVSTFLG is from 'Add Exams to Last Visit' "RTN","RAFLH",84,0) S RAFLHFL=$S($P(RAMDV,"^",2):"ALL",1:"") S:$D(RAVSTFLG) RAFLHFL=RAFLHFL_";"_($O(RAPX(0))-1) "RTN","RAFLH",85,0) S RANUM=$S($P(RAMDV,"^",2):1,1:$P(RAMLC,"^",2)) "RTN","RAFLH",86,0) ; no. flash cards to print : "RTN","RAFLH",87,0) ; if from RAMDV = 1 card only for each exam (procedure) "RTN","RAFLH",88,0) ; if from RAMLC = n cards for the first procedure "RTN","RAFLH",89,0) S RAEXLBLS=+$P(RAMLC,"^",8) "RTN","RAFLH",90,0) ; from orig. devlprs -- if NO default flashcard format, set RAEXFM to 1 "RTN","RAFLH",91,0) S RAEXFM=$S($P(RAMLC,"^",9):$P(RAMLC,"^",9),1:1) "RTN","RAFLH",92,0) K RAVISIT1 I '$P(RAMDV,U,2),$P(RAMLC,U,2) S RAVISIT1=1 "RTN","RAFLH",93,0) ; RAVISIT1 = 1 if paragraph 1's For-loop should be done once only "RTN","RAFLH",94,0) I $D(RASELDEV),RANUM=0,RAEXLBLS=0 K IOP,RAMES,RASELDEV Q "RTN","RAFLH",95,0) ; known problem inherited : "RTN","RAFLH",96,0) ; in the next line, this early quit would mean not printing full amt of "RTN","RAFLH",97,0) ; flash cards, if HOW MANY FLASH CARDS PER VISIT > # procs already prt'd "RTN","RAFLH",98,0) I '$D(RAFLHCNT),$D(RASELDEV),RAEXLBLS=0 K IOP,RAMES,RASELDEV Q "RTN","RAFLH",99,0) I $D(RASELDEV),$D(RAFLHCNT),RAEXLBLS=0 S RASELDEV="Select the FLASH CARD Printer" "RTN","RAFLH",100,0) I '$D(RAFLHCNT),$D(RASELDEV),RAEXLBLS>0 S RASELDEV="Select the EXAM LABEL Printer" "RTN","RAFLH",101,0) I $D(RAFLHCNT),$D(RASELDEV),RANUM=0,RAEXLBLS>0 S RASELDEV="Select the EXAM LABEL Printer" "RTN","RAFLH",102,0) ; "RTN","RAFLH",103,0) Q ;save off variables for TaskMan RACNI, RAMDIV, RASAV2, & RASAV3 added w/RA*5.0*47 "RTN","RAFLH",104,0) S ZTDTH=$H,ZTRTN="DQ^RAFLH" "RTN","RAFLH",105,0) F RASV="RADFN","RADTI","RAFLHFL","RAFLH","RANUM","RAEXLBLS","RAEXFM","RAMDIV","RACNI" S ZTSAVE(RASV)="" "RTN","RAFLH",106,0) S:$D(RAVISIT1) ZTSAVE("RAVISIT1")="" "RTN","RAFLH",107,0) S:$D(RASAV2) ZTSAVE("RASAV2")="" "RTN","RAFLH",108,0) S:$D(RASAV3) ZTSAVE("RASAV3")="" "RTN","RAFLH",109,0) W ! D ZIS^RAUTL Q:RAPOP "RTN","RAFLH",110,0) DQ U IO S U="^" S X="T",%DT="" D ^%DT S DT=Y G RAFLH "RTN","RAFLH",111,0) ; "RTN","RAFLH",112,0) ; If there is a flash card printer associated with the procedure, then "RTN","RAFLH",113,0) ; one flash card will print out at that printer regardless of any "RTN","RAFLH",114,0) ; division or location parameters concerning flash cards. "RTN","RAFLH",115,0) ; "RTN","RAFLH",116,0) ; If there is no flash card printer associated with the procedure and "RTN","RAFLH",117,0) ; the division parameter is set to YES, then one flash card will print "RTN","RAFLH",118,0) ; out at the flash card printer specified in the location parameter. "RTN","RAFLH",119,0) ; If there is no printer specified in the location parameter, then "RTN","RAFLH",120,0) ; the user will be prompted for a device. "RTN","RAFLH",121,0) ; "RTN","RAFLH",122,0) ; If there is no flash card printer associated with the procedure and "RTN","RAFLH",123,0) ; the division parameter is set to NO, then the number of flash cards "RTN","RAFLH",124,0) ; printed out will equal the value in the location parameter field, "RTN","RAFLH",125,0) ; HOW MANY FLASH CARDS PER VISIT. The flash cards will print out at the "RTN","RAFLH",126,0) ; flash card printer specified in the location parameter. If there is "RTN","RAFLH",127,0) ; no printer specified in the location parameter, then the user will be "RTN","RAFLH",128,0) ; prompted for a device. "RTN","RAFLH",129,0) ; "RTN","RAFLH2") 0^37^B4606601 "RTN","RAFLH2",1,0) RAFLH2 ;HISC/GJC-Utility determines if flash cards print. ;4/3/97 07:57 "RTN","RAFLH2",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21 "RTN","RAFLH2",3,0) ; "RTN","RAFLH2",4,0) ;Integration Agreements "RTN","RAFLH2",5,0) ;---------------------- "RTN","RAFLH2",6,0) ;$$NS^XUAF4(2171); $$KSP^XUPARAM(2541) "RTN","RAFLH2",7,0) ; "RTN","RAFLH2",8,0) PRINT(RADIV,RALOC,RAPRC) ; "RTN","RAFLH2",9,0) ; Pass in 'RAMDIV', 'RAMLC' & proc. array i.e, 'RAPX'. "RTN","RAFLH2",10,0) ; Pass back '0' if the print is to be aborted, '>0' to print. "RTN","RAFLH2",11,0) N I,RA71,RA79,RA791,RAFLG,X,X1 "RTN","RAFLH2",12,0) S RA79(.1)=$G(^RA(79,RADIV,.1)),RA791(0)=$G(^RA(79.1,+RALOC,0)) "RTN","RAFLH2",13,0) S RA79(.12)=$S($P(RA79(.1),"^",2)']"":0,"Nn"[$P(RA79(.1),"^",2):0,1:1) "RTN","RAFLH2",14,0) S RA79(.18)=$S($P(RA79(.1),"^",8)']"":0,"Nn"[$P(RA79(.1),"^",8):0,1:1) "RTN","RAFLH2",15,0) S RA791(2)=$S('+$P(RA791(0),"^",2):0,1:1) ; '0' if null or zero "RTN","RAFLH2",16,0) S RA791(4)=$S('+$P(RA791(0),"^",4):0,1:1) ; '0' if null or zero "RTN","RAFLH2",17,0) S RA791(8)=$S('+$P(RA791(0),"^",8):0,1:1) ; '0' if null or zero "RTN","RAFLH2",18,0) ; 'RAPRC' in format of: Case #_^_$G(^RAMIS(71,proc,0)) "RTN","RAFLH2",19,0) ; where 'proc' is the procedure IEN. created in [RA REGISTER] "RTN","RAFLH2",20,0) S I=0 F S I=$O(RAPRC(I)) Q:I'>0 D "RTN","RAFLH2",21,0) . S X=$G(RAPRC(I)),X1=$P(X,"^",5) "RTN","RAFLH2",22,0) . S RA71=+$G(RA71)+($S(X1']"":0,1:1)) "RTN","RAFLH2",23,0) . Q "RTN","RAFLH2",24,0) S RAFLG=+$G(RA71)+RA791(2)+RA791(4)+RA791(8)+RA79(.12)+RA79(.18) "RTN","RAFLH2",25,0) Q RAFLG "RTN","RAFLH2",26,0) KILFLH(X) ; Kill Flash Card Formats variables. "RTN","RAFLH2",27,0) ; X -> IEN of file of the Label Print Fields file. "RTN","RAFLH2",28,0) ; Called from 6^RAMAIN & Q^RAFLH1 "RTN","RAFLH2",29,0) Q:$G(^RA(78.7,X,0))']"" S RA787(0)=$G(^RA(78.7,X,0)) "RTN","RAFLH2",30,0) K @$P(RA787(0),"^",5),RA787(0) "RTN","RAFLH2",31,0) Q "RTN","RAFLH2",32,0) SETFLH(Y) ; Set Flash Card Formats variables. "RTN","RAFLH2",33,0) ; Y -> IEN of file of the Label Print Fields file. "RTN","RAFLH2",34,0) ; Called from 6^RAMAIN & START^RAFLH1 "RTN","RAFLH2",35,0) Q:$G(^RA(78.7,Y,0))']"" S RA787(0)=$G(^RA(78.7,Y,0)) "RTN","RAFLH2",36,0) I $P(RA787(0),U)="LONG CASE NUMBER" D LONGCASE(RA787(0)) Q "RTN","RAFLH2",37,0) S @$P(RA787(0),"^",5)=$P(RA787(0),"^",4) "RTN","RAFLH2",38,0) Q "RTN","RAFLH2",39,0) XECFLH(X,Y) ; Execute the "E" node for the Flash Card Formats file (78.2). "RTN","RAFLH2",40,0) ; X -> IEN of the top level ; Y -> IEN at the first subfile level. "RTN","RAFLH2",41,0) ; Called from RAFLH & RAFLH1 "RTN","RAFLH2",42,0) N I S I=0 "RTN","RAFLH2",43,0) F S I=$O(RAIND1(I)) Q:'+I S ^TMP($J,"RA FLASH",I)=RAIND1(I) "RTN","RAFLH2",44,0) I '$D(RATEST) X ^RA(78.2,X,"E",Y,0) Q "RTN","RAFLH2",45,0) N RASAV,RATMP S RASAV=$G(^RA(78.2,X,"E",Y,0)) "RTN","RAFLH2",46,0) S RATMP=$P(RASAV,"@")_$P(RASAV,"@",2) X RATMP "RTN","RAFLH2",47,0) S ^RA(78.2,X,"E",Y,0)=RASAV "RTN","RAFLH2",48,0) Q "RTN","RAFLH2",49,0) ; "RTN","RAFLH2",50,0) LONGCASE(X) ;Set the INTERNAL VARIABLE (78.7 field 5) to the TEST VALUE (78.7 field 4) "RTN","RAFLH2",51,0) ;when the LABEL PRINT FIELD record is: LONG CASE NUMBER (p47) "RTN","RAFLH2",52,0) ; "RTN","RAFLH2",53,0) ;Input: X-zero node of a file 78.7 record "RTN","RAFLH2",54,0) ; "RTN","RAFLH2",55,0) ;"081194-234" is generic; it is not a direct reference to any specific patient exam. "RTN","RAFLH2",56,0) ; "RTN","RAFLH2",57,0) N RAI S RAI=$$USESSAN^RAHLRU1() ;if RAI use LONG CASE NUMBER w/site prefix "RTN","RAFLH2",58,0) S @$P(X,U,5)=$S(RAI:$E($P($$NS^XUAF4($$KSP^XUPARAM("INST")),U,2),1,3)_"-",1:"")_"081194-234" "RTN","RAFLH2",59,0) Q "RTN","RAFLH2",60,0) ; "RTN","RAHLACK") 0^11^B10346213 "RTN","RAHLACK",1,0) RAHLACK ;HISC/PAV - Process Appl Ack for (ORM) and (ORU) Msgs; 06/23/2006 10:42 "RTN","RAHLACK",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;June 16, 2006;Build 21 "RTN","RAHLACK",3,0) ; Based on information from incoming Ack, e-mail message is "RTN","RAHLACK",4,0) ; sent to Mail group: G.RAD HL7 MESSAGES "RTN","RAHLACK",5,0) ; "RTN","RAHLACK",6,0) ;Integration Agreements "RTN","RAHLACK",7,0) ;---------------------- "RTN","RAHLACK",8,0) ;MSG^DIALOG(2050); $$GETAPP^HLCS2(2887); $$MSG^HLCSUTL(3099);^XMD(10070) "RTN","RAHLACK",9,0) ; "RTN","RAHLACK",10,0) MAIN ; Process incoming ACK, called from 2.4 protocols "RTN","RAHLACK",11,0) ; "RTN","RAHLACK",12,0) N CNT,ERR,ERROR,EXIT,GROUP,HLFS,HLCS,HLSCS,I,NUMBER,RAERR,SEG,X,Y "RTN","RAHLACK",13,0) D INIT,PROCESS,EXIT "RTN","RAHLACK",14,0) Q "RTN","RAHLACK",15,0) ; "RTN","RAHLACK",16,0) INIT ; initialize "RTN","RAHLACK",17,0) ; "RTN","RAHLACK",18,0) ;S DUZ(0)="@" "RTN","RAHLACK",19,0) ; "RTN","RAHLACK",20,0) S ERROR=0 "RTN","RAHLACK",21,0) S HLFS=HL("FS"),HLCS=$E(HL("ECH")) "RTN","RAHLACK",22,0) S HLSCS=$E(HL("ECH"),4),HLREP=$E(HL("ECH"),2) "RTN","RAHLACK",23,0) Q "RTN","RAHLACK",24,0) ; "RTN","RAHLACK",25,0) PROCESS ; pull message text "RTN","RAHLACK",26,0) ; "RTN","RAHLACK",27,0) N SEG "RTN","RAHLACK",28,0) F X HLNEXT Q:HLQUIT'>0 S SEG=$P(HLNODE,HLFS) D:SEG'="" "RTN","RAHLACK",29,0) .D:"^MSH^MSA^ERR^"[(U_SEG_U) @SEG "RTN","RAHLACK",30,0) Q "RTN","RAHLACK",31,0) ; "RTN","RAHLACK",32,0) MSH ; -- MSH segment "RTN","RAHLACK",33,0) ; "RTN","RAHLACK",34,0) Q "RTN","RAHLACK",35,0) ; "RTN","RAHLACK",36,0) MSA ; -- MSA segment "RTN","RAHLACK",37,0) ; "RTN","RAHLACK",38,0) N CODE,DA,DIC,RAHLMA,RAMSA,RAMSG,X "RTN","RAHLACK",39,0) S CODE=$P(HLNODE,HLFS,2) "RTN","RAHLACK",40,0) I CODE="AE"!(CODE="AR") D "RTN","RAHLACK",41,0) .S ERROR=ERROR_U_$P(HLNODE,HLFS,4,99) "RTN","RAHLACK",42,0) .S RAERR("DIMSG",1)=CODE_" ACK Code received to the Message ID: "_$P(HLNODE,HLFS,3) "RTN","RAHLACK",43,0) .S RAMSA=$P(HLNODE,HLFS,3),RAMSG=$$MSG^HLCSUTL(RAMSA,"RAHLMA(1)") "RTN","RAHLACK",44,0) .I RAMSG>0 S RAERR("DIMSG",2)=RAHLMA(1,1) "RTN","RAHLACK",45,0) Q "RTN","RAHLACK",46,0) ; "RTN","RAHLACK",47,0) ERR ; -- ERR segment "RTN","RAHLACK",48,0) ; "RTN","RAHLACK",49,0) ; Set ERR segment handler here... "RTN","RAHLACK",50,0) Q "RTN","RAHLACK",51,0) ; "RTN","RAHLACK",52,0) EM(MID,ERROR,RAERR,XMSUB,XMY) ; error message "RTN","RAHLACK",53,0) ; "RTN","RAHLACK",54,0) N GROUP,RAMPG,RAX,XMDUZ,XMMG,XMTEXT,XMZ "RTN","RAHLACK",55,0) ; "RTN","RAHLACK",56,0) D MSG^DIALOG("AM",.RAX,80,"","RAERR") "RTN","RAHLACK",57,0) ; "RTN","RAHLACK",58,0) S RAX(.1)="HL7 message ID: "_$G(MID) "RTN","RAHLACK",59,0) S RAX(.2)="",RAX(.3)=$G(ERROR) "RTN","RAHLACK",60,0) S:$G(XMSUB)="" XMSUB="RAD ACK ERROR/WARNING/INFO" "RTN","RAHLACK",61,0) S RAMPG=$P($$GETAPP^HLCS2(HL("SAN")),U,1) ;RAMPG="G.RAD HL7 MESSAGES" "RTN","RAHLACK",62,0) S:'$L(RAMPG) RAMPG="G.RAD HL7 MESSAGES" "RTN","RAHLACK",63,0) S XMY(RAMPG)="",XMDUZ=.5 "RTN","RAHLACK",64,0) S XMTEXT="RAX(" "RTN","RAHLACK",65,0) ; "RTN","RAHLACK",66,0) D ^XMD "RTN","RAHLACK",67,0) Q "RTN","RAHLACK",68,0) ; "RTN","RAHLACK",69,0) GSTATUS(HLRESLT,ED) ; "RTN","RAHLACK",70,0) Q:'$D(HLRESLT) "RTN","RAHLACK",71,0) N I,RAERR,ERROR,XMSUB "RTN","RAHLACK",72,0) S XMSUB="RAD HL7: Error in GENERATE^HLMA" "RTN","RAHLACK",73,0) S ERROR="For Event Driver: "_$P($G(^ORD(101,+$G(ED),0)),U) "RTN","RAHLACK",74,0) I +$P(HLRESLT,U,2)!$L($P(HLRESLT,U,3)) D "RTN","RAHLACK",75,0) .S RAERR(1)=$P(HLRESLT,U,2),RAERR(2)=$P(HLRESLT,U,3) "RTN","RAHLACK",76,0) .D EM(+HLRESLT,ERROR_">>"_HLRESLT_"<<",.RAERR,XMSUB_" single subscriber") "RTN","RAHLACK",77,0) .K RAERR "RTN","RAHLACK",78,0) S I=0 F S I=$O(HLRESLT(I)) Q:'I D:$L($P(HLRESLT(I),U,2))!$L($P(HLRESLT(I),U,3)) "RTN","RAHLACK",79,0) .S RAERR(1)=$P(HLRESLT(I),U,2),RAERR(2)=$P(HLRESLT(I),U,3) "RTN","RAHLACK",80,0) .D EM(+HLRESLT(I),ERROR,.RAERR,XMSUB_" multi subscribers") "RTN","RAHLACK",81,0) .K RAERR "RTN","RAHLACK",82,0) Q "RTN","RAHLACK",83,0) ; "RTN","RAHLACK",84,0) ASTATUS(HLRESLT,MID,VNDR) ;ACK error "RTN","RAHLACK",85,0) ; "RTN","RAHLACK",86,0) Q:'$D(HLRESLT) "RTN","RAHLACK",87,0) N I,RAERR,ERROR,XMSUB "RTN","RAHLACK",88,0) S XMSUB="RAD HL7: Error in GENACK^HLMA1" "RTN","RAHLACK",89,0) S ERROR="ACK to:"_VNDR_" Message ID: "_MID "RTN","RAHLACK",90,0) I +$P(HLRESLT,U,2)!$L($P(HLRESLT,U,3)) D "RTN","RAHLACK",91,0) .S RAERR(1)=$P(HLRESLT,U,2),RAERR(2)=$P(HLRESLT,U,3) "RTN","RAHLACK",92,0) .D EM(+HLRESLT,ERROR_">>"_HLRESLT_"<<",.RAERR,XMSUB) "RTN","RAHLACK",93,0) .K RAERR "RTN","RAHLACK",94,0) Q "RTN","RAHLACK",95,0) EXIT ; cleanup, and quit. "RTN","RAHLACK",96,0) Q "RTN","RAHLEXF") 0^23^B22623264 "RTN","RAHLEXF",1,0) RAHLEXF ;HIRMFO/BNT - RAD/NUC MED HL7 Exceptions filer;01/06/99 "RTN","RAHLEXF",2,0) ;;5.0;Radiology/Nuclear Medicine;**12,25,47**;Mar 16, 1998;Build 21 "RTN","RAHLEXF",3,0) ; "RTN","RAHLEXF",4,0) ; "RTN","RAHLEXF",5,0) ; This routine is called from the bridge routine (^RAHLTCPB or TCPX) "RTN","RAHLEXF",6,0) ; when an error occurs while processing an HL7 Message. "RTN","RAHLEXF",7,0) ; The error is stored in the HL7 Message Exceptions File (#79.3) "RTN","RAHLEXF",8,0) ; And, if requested, sent to the HL7 MAIL GROUP for this application "RTN","RAHLEXF",9,0) ; "RTN","RAHLEXF",10,0) Q "RTN","RAHLEXF",11,0) ENX(HLRADT,RAMSG) ; Entry point called from Bridge routine. "RTN","RAHLEXF",12,0) N RAEXFIL,RADT,RAPT,RAEX,RAERRX,SFAC,X,Y,RALNGCS,RAUSR "RTN","RAHLEXF",13,0) ; "RTN","RAHLEXF",14,0) ; File number of Exceptions File "RTN","RAHLEXF",15,0) S RAEXFIL=79.3 "RTN","RAHLEXF",16,0) ; "RTN","RAHLEXF",17,0) ; Date and Time of HL7 Transaction "RTN","RAHLEXF",18,0) S HLRADT=$E(HLRADT,1,14) "RTN","RAHLEXF",19,0) S X=HLRADT,RADT=$$FMDATE^HLFNC(X) "RTN","RAHLEXF",20,0) ; "RTN","RAHLEXF",21,0) ; Radiology Patient Number "RTN","RAHLEXF",22,0) S RAPT=$G(^TMP("RARPT-REC",$J,RASUB,"RADFN")) "RTN","RAHLEXF",23,0) S RAPT="`"_RAPT "RTN","RAHLEXF",24,0) ; "RTN","RAHLEXF",25,0) ; Radiology Case Number "RTN","RAHLEXF",26,0) S RALNGCS=$G(^TMP("RARPT-REC",$J,RASUB,"RALONGCN")) "RTN","RAHLEXF",27,0) S RALNGCS=$P(RALNGCS,"-",$L(RALNGCS,"-")) "RTN","RAHLEXF",28,0) ; "RTN","RAHLEXF",29,0) ; Error (Exception) Text "RTN","RAHLEXF",30,0) S RAERRX=RAERR "RTN","RAHLEXF",31,0) ; "RTN","RAHLEXF",32,0) ; Sending Application Name "RTN","RAHLEXF",33,0) S SFAC=$G(HL("SAN")) "RTN","RAHLEXF",34,0) ; "RTN","RAHLEXF",35,0) ; Name of Verifying Physician or Interpreting staff (COTS unit user) "RTN","RAHLEXF",36,0) S RAUSR=$G(^TMP("RARPT-REC",$J,RASUB,"RAVERF")) "RTN","RAHLEXF",37,0) I RAUSR]"" D "RTN","RAHLEXF",38,0) . D FIND^DIC(200,"",".01","AX",RAUSR,"","","","","RAOUT") "RTN","RAHLEXF",39,0) . Q:'$D(RAOUT("DILIST","ID",1,.01)) "RTN","RAHLEXF",40,0) . S RAUSR=RAOUT("DILIST","ID",1,.01) "RTN","RAHLEXF",41,0) ; "RTN","RAHLEXF",42,0) ; RAMSG = IEN of entry in file 773 - Message Administration file. "RTN","RAHLEXF",43,0) ; "RTN","RAHLEXF",44,0) ; "RTN","RAHLEXF",45,0) ; Go File the exception "RTN","RAHLEXF",46,0) D RAERR "RTN","RAHLEXF",47,0) ; "RTN","RAHLEXF",48,0) ; Send mail message "RTN","RAHLEXF",49,0) D MAIL(SFAC,$G(HL("SAF")),RAERR,RALNGCS,$P(RAPT,"`",2),RADT,RAUSR) "RTN","RAHLEXF",50,0) ; "RTN","RAHLEXF",51,0) D EXIT "RTN","RAHLEXF",52,0) ; "RTN","RAHLEXF",53,0) Q "RTN","RAHLEXF",54,0) EN1 ; Entry point called from Bridge routine. "RTN","RAHLEXF",55,0) N RAEXFIL,RADT,RAPT,RAEX,RAERRX,SFAC,X,Y,RALNGCS,RAUSR,HLRADT,RAMSG "RTN","RAHLEXF",56,0) ; "RTN","RAHLEXF",57,0) ; File number of Exceptions File "RTN","RAHLEXF",58,0) S RAEXFIL=79.3 "RTN","RAHLEXF",59,0) ; "RTN","RAHLEXF",60,0) ; Date and Time of HL7 Transaction "RTN","RAHLEXF",61,0) S HLRADT=$E($P($G(^TMP("RARPT-HL7",$J,1)),"|",7),1,14) "RTN","RAHLEXF",62,0) S X=HLRADT,RADT=$$FMDATE^HLFNC(X) "RTN","RAHLEXF",63,0) ; "RTN","RAHLEXF",64,0) ; Radiology Patient Number "RTN","RAHLEXF",65,0) S RAPT=$G(^TMP("RARPT-REC",$J,RASUB,"RADFN")) "RTN","RAHLEXF",66,0) S RAPT="`"_RAPT "RTN","RAHLEXF",67,0) ; "RTN","RAHLEXF",68,0) ; Radiology Case Number "RTN","RAHLEXF",69,0) S RALNGCS=$G(^TMP("RARPT-REC",$J,RASUB,"RALONGCN")) "RTN","RAHLEXF",70,0) S RALNGCS=$P(RALNGCS,"-",$L(RALNGCS,"-")) "RTN","RAHLEXF",71,0) ; "RTN","RAHLEXF",72,0) ; Error (Exception) Text "RTN","RAHLEXF",73,0) S RAERRX=RAERR "RTN","RAHLEXF",74,0) ; "RTN","RAHLEXF",75,0) ; Sending Application Name "RTN","RAHLEXF",76,0) S SFAC=$G(HL("SAN")) "RTN","RAHLEXF",77,0) ; "RTN","RAHLEXF",78,0) ; Name of Verifying Physician or Interpreting staff (COTS unit user) "RTN","RAHLEXF",79,0) S RAUSR=$G(^TMP("RARPT-REC",$J,RASUB,"RAVERF")) "RTN","RAHLEXF",80,0) I RAUSR]"" D "RTN","RAHLEXF",81,0) . D FIND^DIC(200,"",".01","AX",RAUSR,"","","","","RAOUT") "RTN","RAHLEXF",82,0) . Q:'$D(RAOUT("DILIST","ID",1,.01)) "RTN","RAHLEXF",83,0) . S RAUSR=RAOUT("DILIST","ID",1,.01) "RTN","RAHLEXF",84,0) ; "RTN","RAHLEXF",85,0) ; IEN of entry in file 773 - Message Administration file. "RTN","RAHLEXF",86,0) S RAMSG=$P(^TMP("RARPT-HL7",$J,1),"|",10) "RTN","RAHLEXF",87,0) ; "RTN","RAHLEXF",88,0) ; Go File the exception "RTN","RAHLEXF",89,0) D RAERR "RTN","RAHLEXF",90,0) ; "RTN","RAHLEXF",91,0) ; Send mail message "RTN","RAHLEXF",92,0) D MAIL(SFAC,$G(HL("SAF")),RAERR,RALNGCS,$P(RAPT,"`",2),RADT,RAUSR) "RTN","RAHLEXF",93,0) ; "RTN","RAHLEXF",94,0) D EXIT "RTN","RAHLEXF",95,0) ; "RTN","RAHLEXF",96,0) Q "RTN","RAHLEXF",97,0) RAERR ; Build array and update Exceptions File. "RTN","RAHLEXF",98,0) S RAEX(0,RAEXFIL,"+1,",.01)=RADT "RTN","RAHLEXF",99,0) S RAEX(0,RAEXFIL,"+1,",.02)=SFAC "RTN","RAHLEXF",100,0) S RAEX(0,RAEXFIL,"+1,",1)=RAERRX "RTN","RAHLEXF",101,0) S:$G(RAPT)]"" RAEX(0,RAEXFIL,"+1,",.03)=RAPT "RTN","RAHLEXF",102,0) S:$G(RALNGCS)]"" RAEX(0,RAEXFIL,"+1,",.04)=RALNGCS "RTN","RAHLEXF",103,0) S:$G(RAUSR)]"" RAEX(0,RAEXFIL,"+1,",.06)=RAUSR "RTN","RAHLEXF",104,0) S:$G(RAMSG)]"" RAEX(0,RAEXFIL,"+1,",.05)=RAMSG "RTN","RAHLEXF",105,0) D UPDATE^DIE("E","RAEX(0)","") "RTN","RAHLEXF",106,0) Q "RTN","RAHLEXF",107,0) ; "RTN","RAHLEXF",108,0) MAIL(SAN,SAF,RAERR,RACN,RADFN,RADT,RAUSR) ; Send mail message with error text. "RTN","RAHLEXF",109,0) ; "RTN","RAHLEXF",110,0) ; INPUT PARAMETERS: "RTN","RAHLEXF",111,0) ; SAN = HL7 Sending Application (Required) "RTN","RAHLEXF",112,0) ; SAF = Sending Facility Name "RTN","RAHLEXF",113,0) ; RAERR = Error Message to display (Required) "RTN","RAHLEXF",114,0) ; RACN = Radiology Case Number "RTN","RAHLEXF",115,0) ; RADFN = Rad Patient File (#70) IEN "RTN","RAHLEXF",116,0) ; RADT = Date & Time of HL7 message (FileMan format) "RTN","RAHLEXF",117,0) ; RAUSR = Name of Verifying Physician "RTN","RAHLEXF",118,0) ; "RTN","RAHLEXF",119,0) N RAERTXT,RAMGP,XMY,XMDUZ,XMSUB,Y "RTN","RAHLEXF",120,0) ; "RTN","RAHLEXF",121,0) S RAMGP=$P($$GETAPP^HLCS2(SAN),"^",1) ; Get mail group "RTN","RAHLEXF",122,0) Q:RAMGP="" "RTN","RAHLEXF",123,0) ; "RTN","RAHLEXF",124,0) S RAPT=$P($G(^DPT(+RADFN,0)),"^") "RTN","RAHLEXF",125,0) S:RAPT="" RAPT="UNKNOWN" "RTN","RAHLEXF",126,0) ; "RTN","RAHLEXF",127,0) S RACN=$S($G(RACN)]"":$G(RACN),1:"???") "RTN","RAHLEXF",128,0) S RAUSR=$S($G(RAUSR)]"":$G(RAUSR),1:"UNKNOWN") "RTN","RAHLEXF",129,0) S Y=RADT D DD^%DT S RADT=$S(Y]"":Y,1:"UNKNOWN DATE/TIME") "RTN","RAHLEXF",130,0) S SAF=$S($G(SAF)]"":$G(SAF),1:SAN) "RTN","RAHLEXF",131,0) ; "RTN","RAHLEXF",132,0) S XMDUZ="Rad HL7 Interface Processor" "RTN","RAHLEXF",133,0) ; "RTN","RAHLEXF",134,0) S XMSUB="HL7 message from "_SAF_" application rejected." "RTN","RAHLEXF",135,0) ; "RTN","RAHLEXF",136,0) S RAERTXT(1)="There was a problem processing an HL7 message sent by " "RTN","RAHLEXF",137,0) S RAERTXT(2)=SAF_" on "_RADT_"." "RTN","RAHLEXF",138,0) I $G(HLMTIENS)'="" S RAERTXT(2)=RAERTXT(2)_" Message ien = "_HLMTIENS "RTN","RAHLEXF",139,0) S RAERTXT(3)="" "RTN","RAHLEXF",140,0) S RAERTXT(4)="The report entered on Case #"_RACN_" for "_RAPT "RTN","RAHLEXF",141,0) S RAERTXT(5)="was rejected by Radiology/Nuclear Medicine." "RTN","RAHLEXF",142,0) S RAERTXT(6)="" "RTN","RAHLEXF",143,0) S RAERTXT(7)="The reason given was:" "RTN","RAHLEXF",144,0) S RAERTXT(8)=RAERR "RTN","RAHLEXF",145,0) S RAERTXT(9)="" "RTN","RAHLEXF",146,0) S RAERTXT(10)="( This message has been sent to G."_RAMGP "RTN","RAHLEXF",147,0) S RAERTXT(11)=" and to the verifying physician, "_RAUSR_" )" "RTN","RAHLEXF",148,0) S XMTEXT="RAERTXT(" "RTN","RAHLEXF",149,0) ; "RTN","RAHLEXF",150,0) S:$O(^XMB(3.8,"B",RAMGP,0)) XMY("G."_RAMGP)="" ; send to group "RTN","RAHLEXF",151,0) S:$G(RAUSR)]"" XMY(RAUSR)="" ; send to dictating doctor "RTN","RAHLEXF",152,0) ; "RTN","RAHLEXF",153,0) D ^XMD "RTN","RAHLEXF",154,0) ; "RTN","RAHLEXF",155,0) Q "RTN","RAHLEXF",156,0) EXIT ; Kill variables and return to bridge routine.. "RTN","RAHLEXF",157,0) K RAEX,RADT,RAERRX,RAPT,SFAC,RAEXFIL,RALNGCS,RAUSR,RAMSG,X,Y "RTN","RAHLEXF",158,0) Q "RTN","RAHLO1") 0^64^B66582328 "RTN","RAHLO1",1,0) RAHLO1 ;HIRMFO/GJC/BNT-File rpt (data from bridge program) ;6/25/04 11:49 "RTN","RAHLO1",2,0) ;;5.0;Radiology/Nuclear Medicine;**4,5,12,17,21,27,48,55,66,87,84,94,104,47**;Mar 16, 1998;Build 21 "RTN","RAHLO1",3,0) ; 12/15/2009 BAY/KAM RA*5*104 Rem Call 359702 On-line Verification issue "RTN","RAHLO1",4,0) ; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Correct UNDEF on null dx code "RTN","RAHLO1",5,0) ; 09/07/2005 108405 - KAM/BAY Allow Radiology to accept dx codes from Talk Technology "RTN","RAHLO1",6,0) ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx "RTN","RAHLO1",7,0) ; "RTN","RAHLO1",8,0) ;Integration Agreements "RTN","RAHLO1",9,0) ;---------------------- "RTN","RAHLO1",10,0) ;DIE(10018); ,FILE/UPDATE^DIE(2053); CREATE^WVRALINK(4793); $$NOW^XLFDT(10103) "RTN","RAHLO1",11,0) ;EN^XUSHSHP(10045) "RTN","RAHLO1",12,0) ; "RTN","RAHLO1",13,0) FILE ;Create entry in file 74 & file data (remember: U = "^") "RTN","RAHLO1",14,0) ;Lock an existing report record; quit if unsuccessful. If there is not existing record find "RTN","RAHLO1",15,0) ;the next available record number and then lock the record specific global by calling "RTN","RAHLO1",16,0) ;$$NEWIEN^RAHLTCPU @ line tag NEW1 (lock is implicit; lock set within $$NEWIEN^RAHLTCPU) "RTN","RAHLO1",17,0) ; "RTN","RAHLO1",18,0) I RARPT>0 D LOCKR^RAHLTCPU(.RAERR) Q:$D(RAERR)#2 "RTN","RAHLO1",19,0) N RAFDA,RAIENS "RTN","RAHLO1",20,0) ; "RTN","RAHLO1",21,0) I '$D(ZTQUEUED) N ZTQUEUED S ZTQUEUED="1^dummy to suppress screen displays in UP2^RAUTL1 and elsewhere" "RTN","RAHLO1",22,0) I '$D(RAQUIET) N RAQUIET S RAQUIET="1^dummy to suppress screen display in PTR^RARTE2" "RTN","RAHLO1",23,0) N RADATIME S RADATIME=$$NOW^XLFDT() I $L($P(RADATIME,".",2))>4 S RADATIME=$P(RADATIME,".",1)_"."_$E($P(RADATIME,".",2),1,4) S RADATIME=+RADATIME "RTN","RAHLO1",24,0) N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR "RTN","RAHLO1",25,0) D EN2^RAUTL20(.RAMEMARR) ; 04/30/99 always recalculate RAPRTSET "RTN","RAHLO1",26,0) ; If the report (stub/real) exists, unverify the existing report... Else create a new report "RTN","RAHLO1",27,0) I RARPT,$D(^RARPT(RARPT,0)) S RASAV=RARPT D S RARPT=RASAV K RASAV L:$D(RAERR) -^RARPT(RARPT) Q:$D(RAERR) G LOCK1 "RTN","RAHLO1",28,0) . ; must save off RARPT, RAVERF and other RA* variables because "RTN","RAHLO1",29,0) . ; they are being killed off somewhere in the 'Unverify A Report' "RTN","RAHLO1",30,0) . ; option. 'Unverify A Report' does lock the the report record in file 74! "RTN","RAHLO1",31,0) . N RADFN,RADTI,RACNI,RARPTSTS,RASSN,RADATE,RALONGCN,RAVERF "RTN","RAHLO1",32,0) . ; if report isn't a stub report, then consider it being edited "RTN","RAHLO1",33,0) . S:'$$STUB^RAEDCN1(RARPT) RAEDIT=1 ;log report receipt event as an edit event "RTN","RAHLO1",34,0) . I $D(RADENDUM)#2,($P(^RARPT(RARPT,0),U,5)="V") D Q ;back the report down from verified "RTN","RAHLO1",35,0) .. L -^RARPT(RARPT) ;unlock the report; remember we locked it right after FILE^RAHLO1 "RTN","RAHLO1",36,0) .. D UNVER^RARTE1(RARPT) ;Why the unlock above? Because UNVER^RARTE1 will lock the report "RTN","RAHLO1",37,0) .. S RARPT=RASAV ;RTK 7/28 for RARPT killed in UNVER^RARTE1 "RTN","RAHLO1",38,0) .. D LOCKR^RAHLTCPU(.RAERR) ;re-lock the report after UNVER^RARTE1 releases its lock "RTN","RAHLO1",39,0) .. Q "RTN","RAHLO1",40,0) . K:'($D(RAERR)#2) ^RARPT(RARPT,"I"),^("R"),^("H") "RTN","RAHLO1",41,0) . Q "RTN","RAHLO1",42,0) ; "RTN","RAHLO1",43,0) ; Create a new report record "RTN","RAHLO1",44,0) NEW1 N RARPT S RARPT=$$NEWIEN^RAHLTCPU() "RTN","RAHLO1",45,0) ; "RTN","RAHLO1",46,0) ;we have a new IEN and the record in locked. Now update that record using UPDATE^DIE "RTN","RAHLO1",47,0) S RAIENS(1)=RARPT,RAFDA(74,"+1,",.01)=RALONGCN,RAFDA(74,"+1,",2)=RADFN "RTN","RAHLO1",48,0) ;S RAFDA(74,"+1,",3)=(9999999.9999-RADTI),RAFDA(74,"+1,",4)=$P(RALONGCN,"-",2) "RTN","RAHLO1",49,0) S RAFDA(74,"+1,",3)=(9999999.9999-RADTI),RAFDA(74,"+1,",4)=$P(RALONGCN,"-",$L(RALONGCN,"-")) ;format of RALONGCN after P47 could be SSS-DDDDDD-CASE# so get LAST "-" piece instead of 2nd piece "RTN","RAHLO1",50,0) D UPDATE^DIE("","RAFDA","RAIENS","RAERR") K RAFDA,RAIENS "RTN","RAHLO1",51,0) I $D(RAERR("DIERR"))#2 S RAERR="Error filing a new record in the RAD/NUC MED REPORTS file." L -^RARPT(RARPT) Q "RTN","RAHLO1",52,0) ; "RTN","RAHLO1",53,0) LOCK1 I $D(RAESIG) S X=RAESIG,X1=$G(RAVERF),X2=RARPT D EN^XUSHSHP S RAESIG=X "RTN","RAHLO1",54,0) K RAFDA,RAIENS S RAIENS=RARPT_"," "RTN","RAHLO1",55,0) S RAFDA(74,RAIENS,5)=RARPTSTS ; rpt status "RTN","RAHLO1",56,0) ;Verifier & Verified date will be set if RAVERF exists for new "RTN","RAHLO1",57,0) ;reports, edits, and addendums. Date rpt entered and reported date "RTN","RAHLO1",58,0) ;will be set for new reports, and not reset for edits and addendums "RTN","RAHLO1",59,0) I '($D(RAEDIT)#2),($D(RADATIME)#2) S RAFDA(74,RAIENS,6)=RADATIME ; date/time report entered "RTN","RAHLO1",60,0) I $G(RAVERF)&(RARPTSTS="V") S RAFDA(74,RAIENS,7)=RADATIME ; v'fied date/time "RTN","RAHLO1",61,0) I $D(RADATE)#2 S RAFDA(74,RAIENS,8)=RADATE ; reported date "RTN","RAHLO1",62,0) I $G(RAVERF)&(RARPTSTS="V") S RAFDA(74,RAIENS,9)=RAVERF ; v'fying phys "RTN","RAHLO1",63,0) S:$L($G(RATELENM)) RAFDA(74,RAIENS,9.1)=RATELENM ;Teleradiologist name - Patch 84 "RTN","RAHLO1",64,0) S:$L($G(RATELEPI)) RAFDA(74,RAIENS,9.2)=RATELEPI ;Teleradiologist NPI - Patch 84 "RTN","RAHLO1",65,0) S RAFDA(74,RAIENS,10)=$S($D(RAESIG)&(RARPTSTS="V"):RAESIG,1:"") ;esig "RTN","RAHLO1",66,0) S RAFDA(74,RAIENS,11)=$S($G(RATRANSC):RATRANSC,$G(RAVERF):RAVERF,1:"") ; transcriptionist "RTN","RAHLO1",67,0) ;next: status changed to 'verified' by "RTN","RAHLO1",68,0) I $G(RAVERF),(RARPTSTS="V") S RAFDA(74,RAIENS,17)=$G(^TMP("RARPT-REC",$J,RASUB,"RAWHOCHANGE")) "RTN","RAHLO1",69,0) D FILE^DIE("","RAFDA","RAERR") "RTN","RAHLO1",70,0) I $D(RAERR("DIERR"))#2 D L -^RARPT(RARPT) Q ;if error, unlock f74 and quit. "RTN","RAHLO1",71,0) .S RAERR="Error filing report record data in the RAD/NUC MED REPORTS file." "RTN","RAHLO1",72,0) .;KILL THE WHOLE RECORD??? "RTN","RAHLO1",73,0) .Q "RTN","RAHLO1",74,0) ;-------------------------------------- "RTN","RAHLO1",75,0) ; "RTN","RAHLO1",76,0) ;if case is member of a print set, then create sub-recs for file #74 "RTN","RAHLO1",77,0) I RAPRTSET D "RTN","RAHLO1",78,0) .I '$D(RARPTN) N RARPTN S RARPTN=RALONGCN "RTN","RAHLO1",79,0) .N RAXIT D PTR^RARTE2 ;create corresponding subrecs in ^RARPT() "RTN","RAHLO1",80,0) .Q "RTN","RAHLO1",81,0) ;-------------------------------------- "RTN","RAHLO1",82,0) ; "RTN","RAHLO1",83,0) ;--- start FILE^DIE block for 70.03 --- "RTN","RAHLO1",84,0) ;don't file a Pri. Dx code for teleradiology reports in the released status (P84v11 bus. rule) "RTN","RAHLO1",85,0) S RARELTEL=$S(($D(RATELE)#2)&(RARPTSTS="R"):1,1:"") "RTN","RAHLO1",86,0) ; "RTN","RAHLO1",87,0) ;build the RADFA array to file Dx Code, resident/staff, and the report pointer "RTN","RAHLO1",88,0) ;with a single call to FILE^DIE (silent DBS call) "RTN","RAHLO1",89,0) K RAFDA,RAIENS S RAIENS=RACNI_","_RADTI_","_RADFN_"," "RTN","RAHLO1",90,0) ; "RTN","RAHLO1",91,0) ; 02/08/2008 GJC replaced $G w/($D(RADX)#2) p84 "RTN","RAHLO1",92,0) ; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Changed next line to $G "RTN","RAHLO1",93,0) ; 09/07/2005 108405 KAM/BAY Removed('$D(RADENDUM)#2) from next line "RTN","RAHLO1",94,0) I ($D(RADX)#2),RARELTEL="" D "RTN","RAHLO1",95,0) .S RAFDA(70.03,RAIENS,13)=RADX "RTN","RAHLO1",96,0) .S:$P(^RA(78.3,+RADX,0),U,4)="y" RAAB=1 "RTN","RAHLO1",97,0) .Q "RTN","RAHLO1",98,0) ; "RTN","RAHLO1",99,0) K RARELTEL "RTN","RAHLO1",100,0) S RAZRES=+$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT")) "RTN","RAHLO1",101,0) S RAZSTF=+$G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF")) "RTN","RAHLO1",102,0) ; "RTN","RAHLO1",103,0) I '($D(RADENDUM)#2),(RAZRES!(RAZSTF)) D "RTN","RAHLO1",104,0) .S:$D(^VA(200,"ARC","R",RAZRES)) RAFDA(70.03,RAIENS,12)=RAZRES "RTN","RAHLO1",105,0) .S:$D(^VA(200,"ARC","S",RAZSTF)) RAFDA(70.03,RAIENS,15)=RAZSTF "RTN","RAHLO1",106,0) .Q "RTN","RAHLO1",107,0) ; "RTN","RAHLO1",108,0) S RAZ7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) ;the following business rule needs review "RTN","RAHLO1",109,0) S RAZPCE=$S($D(^VA(200,"ARC","S",+$G(RAVERF))):15,$D(^VA(200,"ARC","R",+$G(RAVERF))):12,1:"") "RTN","RAHLO1",110,0) I '($D(RADENDUM)#2),(RAZPCE),($P(RAZ7003,U,RAZPCE)="") S RAFDA(70.03,RAIENS,RAZPCE)=$G(RAVERF) "RTN","RAHLO1",111,0) ; "RTN","RAHLO1",112,0) ;file the report pointer w/the exam record "RTN","RAHLO1",113,0) S RAFDA(70.03,RAIENS,17)=RARPT "RTN","RAHLO1",114,0) D FILE^DIE(,"RAFDA","RAERR") "RTN","RAHLO1",115,0) I $D(RAERR("DIERR"))#2 D L -^RARPT(RARPT) Q ;if error, unlock f74 and quit. "RTN","RAHLO1",116,0) .N RAFIELD S RAFIELD=$G(RAERR("DIERR",1,"PARAM","FIELD")) "RTN","RAHLO1",117,0) .S RAERR="Error: IENs = "_RAIENS_"; file:70.03; field: "_RAFIELD_" value: "_$S(RAFIELD=13:RADX,RAFIELD=12:RAZRES,RAFIELD=15:RAZSTF,1:RARPT) "RTN","RAHLO1",118,0) K RAFDA,RAIENS,RAZ7003,RAZPCE,RAZRES,RAZSTF "RTN","RAHLO1",119,0) ;---- end FILE^DIE block for 70.03 ---- "RTN","RAHLO1",120,0) ; "RTN","RAHLO1",121,0) ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx "RTN","RAHLO1",122,0) I $D(RASECDX) D "RTN","RAHLO1",123,0) . N RAX S RAX=0 "RTN","RAHLO1",124,0) . F S RAX=$O(RASECDX(RAX)) Q:RAX'>0 D "RTN","RAHLO1",125,0) .. S:$P(^RA(78.3,+RAX,0),U,4)="y" RAAB=1 "RTN","RAHLO1",126,0) ; "RTN","RAHLO1",127,0) ; file impression text if present & not an addendum "RTN","RAHLO1",128,0) I '$D(RADENDUM) D "RTN","RAHLO1",129,0) . S J=0 I $O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0)) S I=0 F J=0:1 S I=$O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",I)) Q:I'>0 I $D(^(I)) S ^RARPT(RARPT,"I",(J+1),0)=$G(^TMP("RARPT-REC",$J,RASUB,"RAIMP",I)) "RTN","RAHLO1",130,0) . S:J ^RARPT(RARPT,"I",0)="^^"_J_U_J_U_RADATE "RTN","RAHLO1",131,0) . Q "RTN","RAHLO1",132,0) ; file report text if present & not an addendum "RTN","RAHLO1",133,0) I '$D(RADENDUM) D "RTN","RAHLO1",134,0) . S J=0 I $O(^TMP("RARPT-REC",$J,RASUB,"RATXT",0)) S I=0 F J=0:1 S I=$O(^TMP("RARPT-REC",$J,RASUB,"RATXT",I)) Q:I'>0 I $D(^(I)) S ^RARPT(RARPT,"R",(J+1),0)=$G(^TMP("RARPT-REC",$J,RASUB,"RATXT",I)) "RTN","RAHLO1",135,0) . S:J ^RARPT(RARPT,"R",0)="^^"_J_U_J_U_RADATE "RTN","RAHLO1",136,0) . Q "RTN","RAHLO1",137,0) ; if addendum, add addendum text to impression or report "RTN","RAHLO1",138,0) I $D(RADENDUM),($O(^TMP("RARPT-REC",$J,RASUB,"RAIMP",0))!$O(^TMP("RARPT-REC",$J,RASUB,"RATXT",0))) D ADENDUM^RAHLO2 ; store new lines at the end of existing text "RTN","RAHLO1",139,0) ; "RTN","RAHLO1",140,0) ; Check for History from Dictation "RTN","RAHLO1",141,0) ; If history sent, check if previous history exists. If previous "RTN","RAHLO1",142,0) ; history then current history will follow adding 'Addendum:' before "RTN","RAHLO1",143,0) ; the text. "RTN","RAHLO1",144,0) I $O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0)) D "RTN","RAHLO1",145,0) . S RACNT=+$O(^RARPT(RARPT,"H",9999999),-1),RAHSTNDE=RACNT+1 "RTN","RAHLO1",146,0) . S RANEW=$S(RACNT>0:0,1:1) "RTN","RAHLO1",147,0) . S I=0 F S I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I)) Q:I'>0 D "RTN","RAHLO1",148,0) . . S RACNT=RACNT+1 "RTN","RAHLO1",149,0) . . S RALN=$G(^TMP("RARPT-REC",$J,RASUB,"RAHIST",I)) "RTN","RAHLO1",150,0) . . S:'RANEW&(I=$O(^TMP("RARPT-REC",$J,RASUB,"RAHIST",0))) RALN="Addendum: "_RALN ; if the first line, append 'Addendum:' "RTN","RAHLO1",151,0) . . I (RAHSTNDE=RACNT),(RACNT>1) S ^RARPT(RARPT,"H",RACNT,0)=" ",RACNT=RACNT+1 "RTN","RAHLO1",152,0) . . S ^RARPT(RARPT,"H",RACNT,0)=RALN "RTN","RAHLO1",153,0) . . Q "RTN","RAHLO1",154,0) . S ^RARPT(RARPT,"H",0)="^^"_RACNT_U_RACNT_U_RADATE "RTN","RAHLO1",155,0) . Q "RTN","RAHLO1",156,0) ; "RTN","RAHLO1",157,0) I $P(^RARPT(RARPT,0),U,5)="V",$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ; women's health "RTN","RAHLO1",158,0) G:'RAPRTSET UPACT ; the next section is for printsets only "RTN","RAHLO1",159,0) ; copy DX (prim & sec), Prim Resid, Prim Staff "RTN","RAHLO1",160,0) N RACNISAV,RA7 "RTN","RAHLO1",161,0) N RA13,RA12,RA15 ;prim dx, prim resid, prim staff, rpt pointer "RTN","RAHLO1",162,0) S RACNISAV=RACNI,RA7=0 "RTN","RAHLO1",163,0) S RA13=$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13),RA12=$P(^(0),U,12),RA15=$P(^(0),U,15) "RTN","RAHLO1",164,0) F S RA7=$O(RAMEMARR(RA7)) Q:RA7="" I RACNISAV'=RA7 S RACNI=RA7 D UPMEM^RAHLO4 I $D(RASECDX),('$D(RADENDUM)#2) D SECDX^RAHLO2 "RTN","RAHLO1",165,0) S RACNI=RACNISAV "RTN","RAHLO1",166,0) ; "RTN","RAHLO1",167,0) UPACT ;Update the Activity Log (74.01) w/DBS call "RTN","RAHLO1",168,0) K RAIENS,RAFDA S RAIENS="+1,"_RARPT_"," "RTN","RAHLO1",169,0) S RAFDA(74.01,RAIENS,.01)=$E($$NOW^XLFDT(),1,12) "RTN","RAHLO1",170,0) S RAFDA(74.01,RAIENS,2)=$S(RARPTSTS="V":"V",$D(RAEDIT):"E",1:"I") "RTN","RAHLO1",171,0) S RAFDA(74.01,RAIENS,3)=$S($G(RAVERF):RAVERF,$G(RATRANSC):RATRANSC,1:"") "RTN","RAHLO1",172,0) D UPDATE^DIE("","RAFDA","RAIENS","") K RAIENS,RAFDA,DIERR,^TMP("DIERR",$J) "RTN","RAHLO1",173,0) ; "RTN","RAHLO1",174,0) ; 12/15/2009 BAY/KAM RA*5*104 Changed next line to rebuild indexes "RTN","RAHLO1",175,0) ;S RAQUEUED=1 ;to be checked in routines "jumped to" from RAHLO1 "RTN","RAHLO1",176,0) S DA=RARPT,DIK="^RARPT(",RAQUEUED=1 D IX^DIK K DA,DIK "RTN","RAHLO1",177,0) ; "RTN","RAHLO1",178,0) L -^RARPT(RARPT) ;unlock the report locked at FILE (existing rpt) or NEW1 (new rpt) "RTN","RAHLO1",179,0) ; "RTN","RAHLO1",180,0) ;If verified, update report & exam statuses; else, just update exam status "RTN","RAHLO1",181,0) ;Note: be careful; exam locks are executed within UP1^RAUTL1! "RTN","RAHLO1",182,0) I $D(RAMDV),RAMDV'="" D:RARPTSTS="V" UPSTAT^RAUTL0 D:RARPTSTS'="V" UP1^RAUTL1 "RTN","RAHLO1",183,0) D:'$D(RAERR)&($G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))'="KURZWEIL") GENACK^RAHLTCPB ; generate 'ACK' message "RTN","RAHLO1",184,0) ; "RTN","RAHLO1",185,0) PACS ;If there are subscribers to RA RPT xxx events broadcast ORU mesages to those subscribers "RTN","RAHLO1",186,0) ;via TASK^RAHLO4. If VOICE DICTATION AUTO-PRINT (#26) field is set to 'Y' print the report to "RTN","RAHLO1",187,0) ;the printer defined in the REPORT PRINTER NAME (#10) field via VOICE^RAHLO4. "RTN","RAHLO1",188,0) I ($P(^RARPT(RARPT,0),U,5)="V")!($P(^(0),U,5)="R") D TASK^RAHLO4,VOICE^RAHLO4 "RTN","RAHLO1",189,0) ; "RTN","RAHLO1",190,0) KVAR K RAAB,RAEDIT,RAESIG,RAQUEUED,RAHIST "RTN","RAHLO1",191,0) Q "RTN","RAHLO1",192,0) ; "RTN","RAHLO3") 0^71^B23427355 "RTN","RAHLO3",1,0) RAHLO3 ;HIRMFO/GJC-Process data set from the bridge program ;11/18/97 12:13 "RTN","RAHLO3",2,0) ;;5.0;Radiology/Nuclear Medicine;**4,81,84,47**;Mar 16, 1998;Build 21 "RTN","RAHLO3",3,0) ; "RTN","RAHLO3",4,0) ;Integration Agreements "RTN","RAHLO3",5,0) ;----------------------- "RTN","RAHLO3",6,0) ;$$GET1^DIQ(2056); $$DT^XLFDT(10103) "RTN","RAHLO3",7,0) ; "RTN","RAHLO3",8,0) RPTSTAT ; Determine the status to set this report to. "RTN","RAHLO3",9,0) K RARPTSTS S:$D(RAESIG) RARPTSTS="V" Q:$D(RARPTSTS) "RTN","RAHLO3",10,0) ; $D(RAESIG)=0 now figure out report status "RTN","RAHLO3",11,0) N RASTAT S RASTAT=$E($G(^TMP("RARPT-REC",$J,RASUB,"RASTAT"))) "RTN","RAHLO3",12,0) I RASTAT="A"!(RASTAT="C") S RARPTSTS="V" Q ;v2.4 "C" (correction) "RTN","RAHLO3",13,0) I RASTAT]"",("FR"[RASTAT) D "RTN","RAHLO3",14,0) . S:RASTAT="F" RARPTSTS="V" Q:$D(RARPTSTS) "RTN","RAHLO3",15,0) . I $G(RATELE) S RARPTSTS="R" Q ;Always allow 'Released/Unverified' reports for teleradiology "RTN","RAHLO3",16,0) . ; do we allow 'Released/Unverified' reports for this location? "RTN","RAHLO3",17,0) . S RARPTSTS=$S($P($G(^RA(79.1,RAMLC,0)),"^",17)="Y":"R",1:"D") "RTN","RAHLO3",18,0) . Q "RTN","RAHLO3",19,0) ; if no status, & there's physician data (verifier/primary),set status "RTN","RAHLO3",20,0) I '$D(RARPTSTS),($G(RAVERF)!$G(^TMP("RARPT-REC",$J,RASUB,"RASTAFF"))!$G(^("RARESIDENT"))) S RARPTSTS=$S($P($G(^RA(79.1,RAMLC,0)),"^",17)="Y":"R",1:"D") "RTN","RAHLO3",21,0) ; if still no status, default to draft "RTN","RAHLO3",22,0) S:'$D(RARPTSTS) RARPTSTS="D" "RTN","RAHLO3",23,0) Q "RTN","RAHLO3",24,0) TEXT(X) ; Check if the Impression Text and the Report Text contain "RTN","RAHLO3",25,0) ; valid characters. "RTN","RAHLO3",26,0) ; Input : X = "I" if Impr Text is being checked, "R" if Rpt Text "RTN","RAHLO3",27,0) ; Output: 0=invalid, 1=valid "RTN","RAHLO3",28,0) N CNT,DATA,FLAG,I,I1,J,Y S (FLAG,I)=0 "RTN","RAHLO3",29,0) F S I=$O(^TMP("RARPT-REC",$J,RASUB,$S(X="I":"RAIMP",1:"RATXT"),I)) Q:I'>0 D Q:FLAG "RTN","RAHLO3",30,0) . S CNT=0,DATA=$G(^TMP("RARPT-REC",$J,RASUB,$S(X="I":"RAIMP",1:"RATXT"),I)) Q:DATA']"" "RTN","RAHLO3",31,0) . F J=1:1:$L(DATA) D Q:FLAG "RTN","RAHLO3",32,0) .. S:$E(DATA,J)?1AN CNT=CNT+1 "RTN","RAHLO3",33,0) .. S:$E(DATA,J)'?1AN&(CNT>0) CNT=0 "RTN","RAHLO3",34,0) .. S:CNT=2 FLAG=1 "RTN","RAHLO3",35,0) .. Q "RTN","RAHLO3",36,0) . Q "RTN","RAHLO3",37,0) Q FLAG "RTN","RAHLO3",38,0) ; "RTN","RAHLO3",39,0) VERCHK ; Check if our provider can verify reports. "RTN","RAHLO3",40,0) ; Examine the following four (4) conditions if $D(RAESIG) "RTN","RAHLO3",41,0) ; 1) Does this person have a resident or staff classification? "RTN","RAHLO3",42,0) ; 2) If a resident, does the division parameter allow resident "RTN","RAHLO3",43,0) ; verification? "RTN","RAHLO3",44,0) ; 3) Does this person hold the "RA VERIFY" key? "RTN","RAHLO3",45,0) ; 4) Is this person an activate Rad/Nuc Med user? "RTN","RAHLO3",46,0) ; 5) Can this person verify reports without staff review? "RTN","RAHLO3",47,0) ; If 'No' to any of the above questions, kill RAESIG & set the variable "RTN","RAHLO3",48,0) ; RAERR to the appropriate error message. "RTN","RAHLO3",49,0) I '$D(^VA(200,"ARC","R",+$G(RAVERF))),('$D(^VA(200,"ARC","S",+$G(RAVERF)))),'$G(RATELE) D Q "RTN","RAHLO3",50,0) . ; neither a resident or staff "RTN","RAHLO3",51,0) . K RAESIG S RAERR="Provider not classified as resident or staff." "RTN","RAHLO3",52,0) . Q "RTN","RAHLO3",53,0) I $D(^VA(200,"ARC","R",+$G(RAVERF))),('$P(RAMDV,"^",18)),'$G(RATELE) D Q "RTN","RAHLO3",54,0) . ; residents can't verify reports linked to this division "RTN","RAHLO3",55,0) . K RAESIG S RAERR="Residents are not permitted to verify reports." "RTN","RAHLO3",56,0) . Q "RTN","RAHLO3",57,0) I '$D(^XUSEC("RA VERIFY",+$G(RAVERF))),'$G(RATELE) D Q "RTN","RAHLO3",58,0) . ; verifier MUST have the RA VERIFY key. "RTN","RAHLO3",59,0) . K RAESIG S RAERR="Provider does not meet security requirements to verify report." "RTN","RAHLO3",60,0) . Q "RTN","RAHLO3",61,0) I '$G(RATELE),$P($G(^VA(200,+$G(RAVERF),"RA")),"^",3),($P(^("RA"),"^",3)'>$$DT^XLFDT()) D "RTN","RAHLO3",62,0) . ; Rad/Nuc Med user has been inactivated. "RTN","RAHLO3",63,0) . K RAESIG S RAERR="Inactive Rad/Nuc Med Classification for Interpreting Physician." "RTN","RAHLO3",64,0) . Q "RTN","RAHLO3",65,0) I '$G(RATELE),'$S('$D(^VA(200,+$G(RAVERF),"RA")):1,$P(^("RA"),"^")'="Y":1,1:0) D "RTN","RAHLO3",66,0) . K RAESIG S RAERR="Staff review required to verify report." "RTN","RAHLO3",67,0) . Q "RTN","RAHLO3",68,0) Q "RTN","RAHLO3",69,0) VFIER ; Check if the RAVERF string is a partial match to an entry in file "RTN","RAHLO3",70,0) ; 200. If if is, check to see that is a partial match to only ONE "RTN","RAHLO3",71,0) ; active provider entry in file 200. "RTN","RAHLO3",72,0) I '$L(RAVERF) S RAERR="Missing Provider information" Q "RTN","RAHLO3",73,0) N RAVCNT,RAVIEN,RAVLGTH,RAVPS "RTN","RAHLO3",74,0) S RAVLGTH=$L(RAVERF) ; length of the RAVERF string "RTN","RAHLO3",75,0) S RAVCNT=0,RAVS1=RAVERF,RAVIEN="" "RTN","RAHLO3",76,0) F S RAVS1=$O(^VA(200,"B",RAVS1)) Q:RAVS1=""!($E(RAVS1,1,RAVLGTH)'=RAVERF) D Q:RAVCNT>1 "RTN","RAHLO3",77,0) . ; return subscripts that have the RAVERF string as the first "RTN","RAHLO3",78,0) . ; 1 - RAVLGTH chars of RAVS1 "RTN","RAHLO3",79,0) . S RAVIEN=0 "RTN","RAHLO3",80,0) . F S RAVIEN=$O(^VA(200,"B",RAVS1,RAVIEN)) Q:RAVIEN'>0 D Q:RAVCNT>1 "RTN","RAHLO3",81,0) .. S RAVPS=$G(^VA(200,RAVIEN,"PS")) "RTN","RAHLO3",82,0) .. S:'$P(RAVPS,"^",4)!($P(RAVPS,"^",4)>DT) RAVCNT=RAVCNT+1 "RTN","RAHLO3",83,0) .. I RAVCNT=1,('$D(RAVIEN(RAVCNT))#2) S RAVIEN(RAVCNT)=RAVIEN ; when "RTN","RAHLO3",84,0) .. ; we find the first active provider save the provider ien off "RTN","RAHLO3",85,0) .. ; in a local array. "RTN","RAHLO3",86,0) .. Q "RTN","RAHLO3",87,0) . Q "RTN","RAHLO3",88,0) ; Added for PowerScribe "RTN","RAHLO3",89,0) I RAVIEN']"" D "RTN","RAHLO3",90,0) . ;S RAVIEN=$P(RAVERF,$E(HL("ECH"),4)) "RTN","RAHLO3",91,0) . S RAVIEN=+RAVERF "RTN","RAHLO3",92,0) . S RAVPS=$G(^VA(200,RAVIEN,"PS")) "RTN","RAHLO3",93,0) . S:'$P(RAVPS,"^",4)!($P(RAVPS,"^",4)>DT) RAVCNT=RAVCNT+1 "RTN","RAHLO3",94,0) . I RAVCNT=1,('$D(RAVIEN(RAVCNT))#2) S RAVIEN(RAVCNT)=RAVIEN "RTN","RAHLO3",95,0) . Q "RTN","RAHLO3",96,0) I RAVCNT=0 S RAERR="Invalid Provider Name: "_RAVERF Q ; partial match not found "RTN","RAHLO3",97,0) I RAVCNT>1 S RAERR="Non-Unique Provider Name: "_RAVERF Q ; >1 partial match "RTN","RAHLO3",98,0) ;S RAVERF=$G(RAVIEN(1)) S:'RAVERF RAERR="Provider Name Entry Error" "RTN","RAHLO3",99,0) S:'$G(RAVIEN(1)) RAERR="Provider Name Entry Error: "_RAVERF S RAVERF=$G(RAVIEN(1)) "RTN","RAHLO3",100,0) Q "RTN","RAHLO3",101,0) ESIG ; Added for COTS E-Sig capability "RTN","RAHLO3",102,0) ; "RTN","RAHLO3",103,0) Q:"FAC"'[^TMP(RARRR,$J,RASUB,"RASTAT")!('$D(^("RAVERF")))!($D(^("RAESIG"))) "RTN","RAHLO3",104,0) S RADFN=+$G(^TMP(RARRR,$J,RASUB,"RADFN")) "RTN","RAHLO3",105,0) S RADTI=+$G(^TMP(RARRR,$J,RASUB,"RADTI")) "RTN","RAHLO3",106,0) S RADIV=$P($G(^RADPT(RADFN,"DT",RADTI,0)),"^",3) "RTN","RAHLO3",107,0) Q:RADIV="" ; exam has been deleted - will be rejected "RTN","RAHLO3",108,0) ; Check division parameters for ALLOW E-SIG ON COTS REPORT in file 79 "RTN","RAHLO3",109,0) ; for the division that ordered this procedure. "RTN","RAHLO3",110,0) I $P(^RA(79,RADIV,.1),"^",27)["Y" D "RTN","RAHLO3",111,0) . S RAESIG=$$GET1^DIQ(200,RAVERF,20.2) "RTN","RAHLO3",112,0) . S:RAESIG]"" ^TMP(RARRR,$J,RASUB,"RAESIG")=RAESIG "RTN","RAHLO3",113,0) . Q "RTN","RAHLO3",114,0) Q "RTN","RAHLR1") 0^12^B24833741 "RTN","RAHLR1",1,0) RAHLR1 ;HISC/GJC - Generate Common Order (ORM) Message ;11/10/99 10:42 "RTN","RAHLR1",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21 "RTN","RAHLR1",3,0) ;Generates msg whenever a case is registered or cancelled or examined "RTN","RAHLR1",4,0) ; registered cancelled examined complete "RTN","RAHLR1",5,0) ; Order control : NW CA XO XO "RTN","RAHLR1",6,0) ; Order status : IP CA IP CM "RTN","RAHLR1",7,0) ; "RTN","RAHLR1",8,0) ;Integration Agreements "RTN","RAHLR1",9,0) ;---------------------- "RTN","RAHLR1",10,0) ;$$GET1^DIQ(10060); NPFON^MAG7UFO(5021); $$FMTHL7^XLFDT(10103) "RTN","RAHLR1",11,0) ;$$HLNAME^XLFNAME(3065); $$NS^XUAF4(2171); $$KSP^XUPARAM(2541) "RTN","RAHLR1",12,0) ; "RTN","RAHLR1",13,0) ;IA: 767 global read on ^DGSL(38.1,D0,0) "RTN","RAHLR1",14,0) ;IA: 10039 global read on ^DIC(42,D0,44) "RTN","RAHLR1",15,0) ;IA: 10040 global read on ^SC(D0 "RTN","RAHLR1",16,0) ; "RTN","RAHLR1",17,0) EN(RADFN,RADTI,RACNI,RAEID) ;Called from RA REG*, RA EXAMINED*, & RA CANCEL* "RTN","RAHLR1",18,0) ;event driver protocols whose HL7 version exceeds version 2.3. "RTN","RAHLR1",19,0) ; "RTN","RAHLR1",20,0) ; Input Variables (from RAHLR): "RTN","RAHLR1",21,0) ; RADFN=file 2 IEN (DFN) "RTN","RAHLR1",22,0) ; RADTI=file 70 Exam subrec IEN (inverse date/time of exam) "RTN","RAHLR1",23,0) ; RACNI=file 70 Case subrecord IEN "RTN","RAHLR1",24,0) ; RAEID=ien of the event driver protocol (defined in RAHLRPC) "RTN","RAHLR1",25,0) ; RACN0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) "RTN","RAHLR1",26,0) ; Output variables: "RTN","RAHLR1",27,0) ; HLA("HLS", array containing HL7 msg "RTN","RAHLR1",28,0) ; "RTN","RAHLR1",29,0) N RAPID,RAPV1,RAORC,RAOBR,RAOBX,RAX,X,XX,I,I1,I2,I3,II "RTN","RAHLR1",30,0) ;initialize Rad/Nuc Med specific variables "RTN","RAHLR1",31,0) D:'$D(HLFS)!'$D(HL) INIT^RAHLRU "RTN","RAHLR1",32,0) D INIT "RTN","RAHLR1",33,0) ;RA*5*82 RAEXEDT= Override the EXM conditions if Case edited "RTN","RAHLR1",34,0) I '$G(RAEXEDT),$G(RAEXMDUN)=1,$P(RAZXAM,U,30)'="" Q ;last chance to stop exm'd msg if it's already been sent "RTN","RAHLR1",35,0) ; "RTN","RAHLR1",36,0) PID ;compile the PID segment "RTN","RAHLR1",37,0) D PID^RAHLRU1(+RADFN) "RTN","RAHLR1",38,0) ; "RTN","RAHLR1",39,0) PV1 ;compile the PV1 segment determine if the patient is "RTN","RAHLR1",40,0) ;an inpatient or outpatient by looking at the exam record "RTN","RAHLR1",41,0) D PV1^RAHLRU1(+RADFN) "RTN","RAHLR1",42,0) ; "RTN","RAHLR1",43,0) ORC ;build the 'common order segment (ORC) segment "RTN","RAHLR1",44,0) ;RACANC is the status of the exam 'cancelled'? If ORDER (#3) field in "RTN","RAHLR1",45,0) ;the EXAMINATION STATUS (#72) file is set to zero, the exam has been "RTN","RAHLR1",46,0) ;cancelled. If order is set to nine, the exam is complete. "RTN","RAHLR1",47,0) S RAXAMSTS=$P($G(^RA(72,+$P(RAZXAM,U,3),0)),U,3) "RTN","RAHLR1",48,0) S RACANC=$S(RAXAMSTS=0:1,1:0),RACOMP=$S(RAXAMSTS=9:1,1:0) "RTN","RAHLR1",49,0) S RAORC(2)=$S(RACANC:"CA",$G(RAEXMDUN)=1:"XO",1:"NW") "RTN","RAHLR1",50,0) ; define ORC-2 & ORC-3 to 'site id-mmddyy-case#' ex: 141-041106-6 "RTN","RAHLR1",51,0) ; 9/2008 -- check Site Acc Number division parameter (79,.131) and only "RTN","RAHLR1",52,0) ; use the long site specific acc num if set to YES, else use old form "RTN","RAHLR1",53,0) S (RAORC(3),RAORC(4))=RAZDAYCS "RTN","RAHLR1",54,0) S RAORC(6)=$S(RACANC:"CA",RACOMP:"CM",1:"IP") "RTN","RAHLR1",55,0) ; "RTN","RAHLR1",56,0) ;new logic in determining the value of order status (ORC-5) "RTN","RAHLR1",57,0) ;discovered in the development and testing of p47 on 01/14/2010 "RTN","RAHLR1",58,0) ;Variables: "RTN","RAHLR1",59,0) ; RA101Z - defined in RAHLRPC "RTN","RAHLR1",60,0) ; RAOPT - array set/killed in the entry/exit actions in options: "RTN","RAHLR1",61,0) ;- [RA HL7 MESSAGE RESEND] "RTN","RAHLR1",62,0) ;- [RA HL7 RESEND BY DATE RANGE] "RTN","RAHLR1",63,0) ; these two options may impact the definition of ORC-5 "RTN","RAHLR1",64,0) I $E($O(RAOPT("")),1,6)="RESEND",($E($G(RA101Z),1,6)="RA REG") S RAORC(6)="IP" "RTN","RAHLR1",65,0) ;Executing the RA REG* event driver(s) should send an order control (ORC-1) "RTN","RAHLR1",66,0) ;value of 'NW' & an order status value of 'IP' when the aforementioned options "RTN","RAHLR1",67,0) ;are exercised. "RTN","RAHLR1",68,0) ; "RTN","RAHLR1",69,0) ;Quantity/Timing ORC-7.4 SCHEDULED DATE (TIME optional) 75.1;23 "RTN","RAHLR1",70,0) ;Priority ORC-7.6 REQUEST URGENCY of order 75.1;6 "RTN","RAHLR1",71,0) S RAORC(8)=$$REPEAT^RAHLRU1($E(HLECH,1),3)_$$FMTHL7^XLFDT($P(RAZORD,U,23))_$$REPEAT^RAHLRU1($E(HLECH,1),2)_$S($P(RAZORD,U,6)=1:"S",$P(RAZORD,U,6)=2:"A",1:"R") "RTN","RAHLR1",72,0) ;Parent ORC-8 MEMBER OF SET (70.03;25); PURGED DATE (70.03,40) "RTN","RAHLR1",73,0) S RAORC(9)=$$PARENT(RAPURGE,$P(RAZXAM,U,25)) "RTN","RAHLR1",74,0) ;Note: ORC-8 & OBR-29 share the same value "RTN","RAHLR1",75,0) ; "RTN","RAHLR1",76,0) ;S RAORC(10)=$$FMTHL7^XLFDT($P(RAZORD,U,16)) ;transaction d/t (order) "RTN","RAHLR1",77,0) S RAORC(10)=$$FMTHL7^XLFDT($P(RAZRXAM,U)) ;transaction d/t (exam d/t registered) "RTN","RAHLR1",78,0) ; "RTN","RAHLR1",79,0) ;Entered By ORC-10 (USER ENTERING REQUEST) 75.1;15 "RTN","RAHLR1",80,0) I $P(RAZORD,U,15),($$GET1^DIQ(200,$P(RAZORD,U,15),.01)'="") D "RTN","RAHLR1",81,0) .S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZORD,U,15) "RTN","RAHLR1",82,0) .S RAZNME("FIELD")=.01 "RTN","RAHLR1",83,0) .S RAORC(11)=$P(RAZORD,U,15)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E($G(HLECH))) "RTN","RAHLR1",84,0) .Q "RTN","RAHLR1",85,0) ;Ordering Provider ORC-12 (REQUESTING PHYSICIAN) 75.1;14 "RTN","RAHLR1",86,0) I $P(RAZORD,U,14),($$GET1^DIQ(200,$P(RAZORD,U,14),.01)'="") D "RTN","RAHLR1",87,0) .K RAZNME S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZORD,U,14) "RTN","RAHLR1",88,0) .S RAZNME("FIELD")=.01 "RTN","RAHLR1",89,0) .S RAORC(13)=$P(RAZORD,U,14)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E($G(HLECH))) "RTN","RAHLR1",90,0) .Q "RTN","RAHLR1",91,0) ;Enterer's Location ORC-13 (USER ENTERING REQUEST) "RTN","RAHLR1",92,0) S RASERSEC=$$ESCAPE^RAHLRU($$GET1^DIQ(200,$P(RAZORD,U,15),29)) "RTN","RAHLR1",93,0) S RAORC(14)=RASERSEC ;SERVICE/SECTION "RTN","RAHLR1",94,0) ; "RTN","RAHLR1",95,0) ;Call Back Phone numbers of Ordering Provider ORC-14 "RTN","RAHLR1",96,0) D "RTN","RAHLR1",97,0) .N RAX,I,M S M="",I=0 "RTN","RAHLR1",98,0) .D NPFON^MAG7UFO("RAX",$P(RAZORD,U,14)) "RTN","RAHLR1",99,0) .F S I=$O(RAX(I)) Q:'I S M=M_$$ESCAPE^RAHLRU($G(RAX(I,1,1)))_$E(HLECH)_$G(RAX(I,2,1))_$E(HLECH)_$G(RAX(I,3,1))_$E(HLECH,2) "RTN","RAHLR1",100,0) .S:$L(M) RAORC(15)=$E(M,1,$L(M)-1) "RTN","RAHLR1",101,0) ; "RTN","RAHLR1",102,0) ;Enterer's Organization ORC-17 (USER ENTERING REQUEST) "RTN","RAHLR1",103,0) S RASERSEC(0)=+$$GET1^DIQ(200,$P(RAZORD,U,15),29,"I") ;pointer to 49 "RTN","RAHLR1",104,0) S RASERSEC(1)=$$GET1^DIQ(49,RASERSEC(0),1) ;abbr. of service/section "RTN","RAHLR1",105,0) S RAORC(18)=RASERSEC(1)_$E(HLECH)_RASERSEC_$E(HLECH)_"VISTA49" "RTN","RAHLR1",106,0) ;build the ORC segment; set the HLA array "RTN","RAHLR1",107,0) D BLSEG^RAHLRU1("ORC",.RAORC) "RTN","RAHLR1",108,0) K RACANC,RACOMP,RASERSEC,RAXAMSTS,RAZNME,RAZPHONE "RTN","RAHLR1",109,0) ; "RTN","RAHLR1",110,0) D:$T(EN^RAHLR1A)]"" EN^RAHLR1A ;continue building the OBR, OBX, & ZDS segments "RTN","RAHLR1",111,0) ; "RTN","RAHLR1",112,0) ; Broadcast the HL7 message and cleanup the symbol table "RTN","RAHLR1",113,0) D GENERATE^RAHLRU "RTN","RAHLR1",114,0) Q "RTN","RAHLR1",115,0) ; "RTN","RAHLR1",116,0) INIT ;initialize some basic package specific variables "RTN","RAHLR1",117,0) S:'($D(U)#2) U="^" "RTN","RAHLR1",118,0) S RAZRXAM=$G(^RADPT(RADFN,"DT",RADTI,0)) ;reg. exam zero node "RTN","RAHLR1",119,0) S RAZXAM=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) ;exam zero node "RTN","RAHLR1",120,0) S RAPURGE=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PURGE")) "RTN","RAHLR1",121,0) S RAZDTE=9999999.9999-RADTI ;FM internal date/time "RTN","RAHLR1",122,0) ; Check if SSAN exists for the exam: "RTN","RAHLR1",123,0) ; Field: [^DD(70.03,31,0)=SITE ACCESSION NUMBER^RFI^^0;31] "RTN","RAHLR1",124,0) ; This check should NOT be dependent on the current state of the "RTN","RAHLR1",125,0) ; SSAN Switch (ON or OFF), don't build RAZDAYCS on the fly, use the "RTN","RAHLR1",126,0) ; data stored in the exam (legacy accession number or SSAN) "RTN","RAHLR1",127,0) ; if SSAN exists set RAZDAYCS=SSAN "RTN","RAHLR1",128,0) ; if SSAN does not exist set RAZDAYCS=legacy accession number "RTN","RAHLR1",129,0) I $P(RAZXAM,"^",31)="" S RAZDAYCS=$E(RAZDTE,4,7)_$E(RAZDTE,2,3)_"-"_+RAZXAM ;Legacy Accession Number: mmddyy-case# "RTN","RAHLR1",130,0) I $P(RAZXAM,"^",31)'="" S RAZDAYCS=$P(RAZXAM,"^",31) ;SSAN: sss-mmddyy-case# "RTN","RAHLR1",131,0) ; "RTN","RAHLR1",132,0) S RAZORD=$G(^RAO(75.1,+$P(RAZXAM,U,11),0)) ;rad/nuc med order zero node "RTN","RAHLR1",133,0) S RAZORD1=$P($G(^RAO(75.1,+$P(RAZXAM,U,11),.1)),U) ;rad/nuc reason for study "RTN","RAHLR1",134,0) S RAZPROC=$G(^RAMIS(71,+$P(RAZXAM,U,2),0)) ;exam specific procedure "RTN","RAHLR1",135,0) Q "RTN","RAHLR1",136,0) ; "RTN","RAHLR1",137,0) PARENT(PRGE,PRNT) ;Define fields ORC-8 & OBR-29 known as PARENT "RTN","RAHLR1",138,0) ; input: PRGE=purge date of the exam (if applicable) "RTN","RAHLR1",139,0) ; PRNT=parent/descendant if yes, specify if exam or printset "RTN","RAHLR1",140,0) ;return: VALUE=ORIGINAL ORDER PURGED if purged, EXAMSET: proc_name "RTN","RAHLR1",141,0) ; if examset, PRINTSET: proc_name if printset, or null. "RTN","RAHLR1",142,0) I PRGE,(PRGE'>DT) S VALUE="ORIGINAL ORDER PURGED" "RTN","RAHLR1",143,0) I PRNT S VALUE=$S(PRNT=1:"Examset: ",1:"Printset: ")_$P($G(^RAMIS(71,+$P(RAZORD,U,2),0)),U) "RTN","RAHLR1",144,0) Q $G(VALUE) "RTN","RAHLR1",145,0) ; "RTN","RAHLR1A") 0^13^B53486094 "RTN","RAHLR1A",1,0) RAHLR1A ;HISC/GJC - Generate Common Order (ORM) Message ;11/10/99 10:42 "RTN","RAHLR1A",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21 "RTN","RAHLR1A",3,0) ; "RTN","RAHLR1A",4,0) ; "RTN","RAHLR1A",5,0) ;Integration Agreements "RTN","RAHLR1A",6,0) ;---------------------- "RTN","RAHLR1A",7,0) ;$$GET1^DIQ(2056); ^DIWP(10011); NPFON^MAG7UFO(5021) "RTN","RAHLR1A",8,0) ;$$ZDS^MAGDRAHL(5022); $$FMTHL7^XLFDT(10103); $$HLNAME^XLFNAME(3065) "RTN","RAHLR1A",9,0) ; "RTN","RAHLR1A",10,0) ;IA: 767 global read on ^DGSL(38.1,D0,0) "RTN","RAHLR1A",11,0) ;calls to $$GET1^DIQ(44,IEN,.01) covered by IA: 10040 "RTN","RAHLR1A",12,0) ;calls to $$GET1^DIQ(4,IEN,.01) covered by IA: 10090 "RTN","RAHLR1A",13,0) ; "RTN","RAHLR1A",14,0) EN ;Called from RAHLR1; used to build the OBR, OBX, & ZDS segments "RTN","RAHLR1A",15,0) ;The following key variables are defined in INIT^RAHLR1 "RTN","RAHLR1A",16,0) ;RAZRXAM=reg. exam zero node "RTN","RAHLR1A",17,0) ;RAZXAM=exam zero node "RTN","RAHLR1A",18,0) ;RAZDTE=9999999.9999-RADTI ;FM internal date/time "RTN","RAHLR1A",19,0) ;RAZDAYCS: "RTN","RAHLR1A",20,0) ; IF SSAN SITE PARAMETER="Y" RAZDAYCS=SSAN (sss-mmddyy-case#) "RTN","RAHLR1A",21,0) ; ELSE IF SSAN'="Y" RAZDAYCS=DAY CASE# (mmddyy-case#) "RTN","RAHLR1A",22,0) ;RAZORD=rad/nuc med order zero node "RTN","RAHLR1A",23,0) ;RAZPROC=exam specific procedure "RTN","RAHLR1A",24,0) ; "RTN","RAHLR1A",25,0) ;Note: RAOBR(n+1) = OBR-'n' because our software begins "RTN","RAHLR1A",26,0) ;building the segment with the segment header ('OBR') "RTN","RAHLR1A",27,0) ; "RTN","RAHLR1A",28,0) ;new some variables... "RTN","RAHLR1A",29,0) N %,DN,FT,I,J,PI,PTR,X,Y,Z,RAX,RAXX "RTN","RAHLR1A",30,0) ;Compile OBR Segment "RTN","RAHLR1A",31,0) ;Set ID OBR-1 "RTN","RAHLR1A",32,0) OBRPRC ;OBR segment "RTN","RAHLR1A",33,0) S RAOBR(2)=1 "RTN","RAHLR1A",34,0) ;Placer Order Number OBR-2 site id-mmddyy-case# "RTN","RAHLR1A",35,0) ;Filler Order Number OBR-3 site id-mmddyy-case# "RTN","RAHLR1A",36,0) ; RAZDAYCS will be set to SSAN (site specific acc number) if the Site "RTN","RAHLR1A",37,0) ; Acc Number division parameter (79,.131)=YES, else DAY CASE# format "RTN","RAHLR1A",38,0) S (RAOBR(3),RAOBR(4))=RAZDAYCS "RTN","RAHLR1A",39,0) S RAZCPT=$P(RAZPROC,U,9),RAZCPT(0)=$$NAMCODE^RACPTMSC(RAZCPT,DT) "RTN","RAHLR1A",40,0) ;RAZCPT(0)=CPT code from file 81^short name of CPT code from file 81 "RTN","RAHLR1A",41,0) ;RAOBR(5)=CPT code #81_comp sep_CPT code short name #81_comp sep_"C4" "RTN","RAHLR1A",42,0) ; _comp sep_IEN file #71_comp sep_procedure name #71_comp sep_ "RTN","RAHLR1A",43,0) ; "99RAP" "RTN","RAHLR1A",44,0) ; "RTN","RAHLR1A",45,0) S RAOBR(5)=$P(RAZCPT(0),U)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAZCPT(0),U,2))_$E(HLECH)_"C4" "RTN","RAHLR1A",46,0) S RAOBR(5)=RAOBR(5)_$E(HLECH)_+$P(RAZXAM,U,2)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAZPROC,U))_$E(HLECH)_"99RAP" "RTN","RAHLR1A",47,0) ;Priority OBR-5 (REQUEST URGENCY) 75.1;6 "RTN","RAHLR1A",48,0) S RAOBR(6)=$S($P(RAZORD,U,6)=1:"S",$P(RAZORD,U,6)=2:"A",1:"R") "RTN","RAHLR1A",49,0) ;Specimen Source OBR-15 75.1;125 PROCEDURE MODIFIERS (mult: 75.1125) "RTN","RAHLR1A",50,0) ;(left & right only) "RTN","RAHLR1A",51,0) S RAZPMOD=$$SPECSRC^RAHLRU1(+$P(RAZXAM,U,11)) "RTN","RAHLR1A",52,0) S:$L(RAZPMOD) RAOBR(16)=$$REPEAT^RAHLRU1($E(HLECH),4)_$E(HLECH,4)_RAZPMOD "RTN","RAHLR1A",53,0) ; "RTN","RAHLR1A",54,0) ;Ordering Provider OBR-16 (REQUESTING PHYSICIAN) 75.1;14 "RTN","RAHLR1A",55,0) I $P(RAZORD,U,14),($$GET1^DIQ(200,$P(RAZORD,U,14),.01)'="") D "RTN","RAHLR1A",56,0) .K RAZNME S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZORD,U,14) "RTN","RAHLR1A",57,0) .S RAZNME("FIELD")=.01 "RTN","RAHLR1A",58,0) .S RAOBR(17)=$P(RAZORD,U,14)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1)) "RTN","RAHLR1A",59,0) .Q "RTN","RAHLR1A",60,0) ; "RTN","RAHLR1A",61,0) ;Call Back Phone numbers of Ordering Provider OBR-17 (mirrors ORC-14) "RTN","RAHLR1A",62,0) D "RTN","RAHLR1A",63,0) .N RAX,I,M S M="",I=0 "RTN","RAHLR1A",64,0) .D NPFON^MAG7UFO("RAX",$P(RAZORD,U,14)) "RTN","RAHLR1A",65,0) .F S I=$O(RAX(I)) Q:'I S M=M_$$ESCAPE^RAHLRU($G(RAX(I,1,1)))_$E(HLECH)_$G(RAX(I,2,1))_$E(HLECH)_$G(RAX(I,3,1))_$E(HLECH,2) "RTN","RAHLR1A",66,0) .S:$L(M) RAOBR(18)=$E(M,1,$L(M)-1) "RTN","RAHLR1A",67,0) ; "RTN","RAHLR1A",68,0) ;Placer Field 1 OBR-18 site id-mmddyy-case# (mirrors OBR-2 & OBR-3) "RTN","RAHLR1A",69,0) S RAOBR(19)=RAZDAYCS "RTN","RAHLR1A",70,0) ; "RTN","RAHLR1A",71,0) ;Placer Field 2 definition has been changed by a VistA Imaging request "RTN","RAHLR1A",72,0) ;-> prior to 07/2007: inv. date/time of the exam concatenated to (by the "RTN","RAHLR1A",73,0) ; dash) the exam record IEN (Placer Fld 2 OBR-19 = Filler Fld 1 OBR-20) "RTN","RAHLR1A",74,0) ;-> after 07/2007: case number "RTN","RAHLR1A",75,0) ;RAZDAYCS=sss-mmddyy-case# OR mmddyy-case# "RTN","RAHLR1A",76,0) S RAOBR(20)=$P(RAZDAYCS,"-",$L(RAZDAYCS,"-")) "RTN","RAHLR1A",77,0) ; "RTN","RAHLR1A",78,0) ;Filler Field 1 OBR-20 is defined as the site specific accession number: "RTN","RAHLR1A",79,0) ;site id-mmddyy-case# Note: same value as OBR-18, OBR-2, & OBR-3 "RTN","RAHLR1A",80,0) ;(change effective 07/2007) "RTN","RAHLR1A",81,0) S RAOBR(21)=RAZDAYCS "RTN","RAHLR1A",82,0) ; "RTN","RAHLR1A",83,0) ;Filler Field 2 OBR-21 "RTN","RAHLR1A",84,0) S RAOBR(22)=$$OBR21^RAHLRU(HLECH,RAZRXAM) "RTN","RAHLR1A",85,0) ; "RTN","RAHLR1A",86,0) ;Diagnostic Service Section ID OBR-24 MODALITY 71.0731 ptr to #73.1 "RTN","RAHLR1A",87,0) ;we capture modality data if there is only one sub-file record "RTN","RAHLR1A",88,0) S RAZIEN=+$O(^RAMIS(71,+$P(RAZXAM,U,2),"MDL",0)) "RTN","RAHLR1A",89,0) I RAZIEN,(RAZIEN=$O(^RAMIS(71,+$P(RAZXAM,U,2),"MDL",$C(32)),-1)) D "RTN","RAHLR1A",90,0) .S RAZMODAL=+$G(^RAMIS(71,+$P(RAZXAM,U,2),"MDL",RAZIEN,0)) "RTN","RAHLR1A",91,0) .S RAOBR(25)=$$ESCAPE^RAHLRU($P($G(^RAMIS(73.1,RAZMODAL,0)),U)) "RTN","RAHLR1A",92,0) .Q "RTN","RAHLR1A",93,0) ;Quantity/Timing OBR-27.4 equates to SCHEDULED DATE (TIME optional) "RTN","RAHLR1A",94,0) ; 75.1;23 Priority OBR-27.6 equates to REQUEST URGENCY of order 75.1;6 "RTN","RAHLR1A",95,0) ;Quantity/Timing OBR-27 (OBR-27 & ORC-7 share the same value) "RTN","RAHLR1A",96,0) S RAOBR(28)=$$REPEAT^RAHLRU1($E(HLECH,1),3)_$$FMTHL7^XLFDT($P(RAZORD,U,23))_$$REPEAT^RAHLRU1($E(HLECH,1),2)_$S($P(RAZORD,U,6)=1:"S",$P(RAZORD,U,6)=2:"A",1:"R") "RTN","RAHLR1A",97,0) ; "RTN","RAHLR1A",98,0) ;Parent OBR-29 (OBR-29 & ORC-8 share the same value) "RTN","RAHLR1A",99,0) S RAOBR(30)=$G(RAORC(9)) ;see PARENT^RAHLR1 "RTN","RAHLR1A",100,0) ; "RTN","RAHLR1A",101,0) ;Transportation Mode OBR-30 75.1;19 "RTN","RAHLR1A",102,0) S RAZTMODE=$P(RAZORD,U,19) "RTN","RAHLR1A",103,0) S RAOBR(31)=$S(RAZTMODE="a":"WALK",RAZTMODE="w":"WHLC",RAZTMODE="s":"CART",RAZTMODE="p":"PORT",1:"") "RTN","RAHLR1A",104,0) ;Reason for Study OBR-31 "RTN","RAHLR1A",105,0) S $P(RAOBR(32),HLCS,2)=$S($L(RAZORD1):RAZORD1,1:"See Clinical History:") "RTN","RAHLR1A",106,0) ;build the OBR segment "RTN","RAHLR1A",107,0) D BLSEG^RAHLRU1("OBR",.RAOBR) "RTN","RAHLR1A",108,0) ;build the ZDS segment "RTN","RAHLR1A",109,0) D ZDS(RADTI,RACNI,RAZDAYCS) "RTN","RAHLR1A",110,0) ; "RTN","RAHLR1A",111,0) OBXPRC ;Compile 'OBX' Segment for Procedure "RTN","RAHLR1A",112,0) ;RAXX = Counter in segment "RTN","RAHLR1A",113,0) S (RAOBX(2),RAXX)=1 "RTN","RAHLR1A",114,0) S RAOBX(3)="CE",RAOBX(4)="P"_$E(HLECH)_"PROCEDURE"_$E(HLECH)_"L" "RTN","RAHLR1A",115,0) S RAOBX(6)=$P(RAZXAM,U,2)_$E(HLECH)_$$ESCAPE^RAHLRU($P($G(^RAMIS(71,+$P(RAZXAM,U,2),0)),U))_$E(HLECH)_"L" "RTN","RAHLR1A",116,0) S RAOBX(12)="O" "RTN","RAHLR1A",117,0) D BLSEG^RAHLRU1("OBX",.RAOBX) K RAOBX "RTN","RAHLR1A",118,0) ; "RTN","RAHLR1A",119,0) OBXPMOD ;Compile 'OBX' segment for procedure modifiers "RTN","RAHLR1A",120,0) S RAOBX(2)=$G(RAXX) "RTN","RAHLR1A",121,0) S RAOBX(3)="TX",RAOBX(4)="M"_$E(HLECH)_"MODIFIERS"_$E(HLECH)_"L" "RTN","RAHLR1A",122,0) S RAOBX(12)="O",(I,J)=0 "RTN","RAHLR1A",123,0) F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I)) Q:'I D "RTN","RAHLR1A",124,0) .S PTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I,0)) "RTN","RAHLR1A",125,0) .S J=J+1,RAOBX(2)=RAXX+J,RAOBX(6)=$$ESCAPE^RAHLRU($P($G(^RAMIS(71.2,PTR,0)),U)) "RTN","RAHLR1A",126,0) .D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLR1A",127,0) .Q "RTN","RAHLR1A",128,0) S RAXX=RAOBX(2) "RTN","RAHLR1A",129,0) K RAOBX "RTN","RAHLR1A",130,0) ; "RTN","RAHLR1A",131,0) OBXCPTM ;Compile 'OBX' segment for CPT modifiers "RTN","RAHLR1A",132,0) S RAOBX(2)=$G(RAXX) "RTN","RAHLR1A",133,0) S RAOBX(3)="CE",RAOBX(4)="C4"_$E(HLECH)_"CPT MODIFIERS"_$E(HLECH)_"L" "RTN","RAHLR1A",134,0) S RAOBX(12)="O",(I,J)=0 "RTN","RAHLR1A",135,0) F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",I)) Q:'I D "RTN","RAHLR1A",136,0) .S PTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",I,0)) "RTN","RAHLR1A",137,0) .S J=J+1,RAOBX(2)=RAXX+J,RAOBX(6)=$$CPTMOD^RAHLRU(PTR,HLECH,DT) "RTN","RAHLR1A",138,0) .D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLR1A",139,0) S RAXX=RAOBX(2) "RTN","RAHLR1A",140,0) K RAOBX,RAZCPTM "RTN","RAHLR1A",141,0) ; "RTN","RAHLR1A",142,0) OBXHIST ;Compile 'OBX' Segment for Clinical History "RTN","RAHLR1A",143,0) I $L(RAZORD1) D ;add Reason for Study as a prefix "RTN","RAHLR1A",144,0) .S RAXX=RAXX+1,RAOBX(2)=RAXX,RAOBX(3)="TX" "RTN","RAHLR1A",145,0) .S RAOBX(4)="H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L",RAOBX(12)="O" "RTN","RAHLR1A",146,0) .S RAOBX(6)="Reason for Study: "_$$ESCAPE^RAHLRU($G(RAZORD1)) "RTN","RAHLR1A",147,0) .D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLR1A",148,0) .S RAXX=RAXX+1,RAOBX(2)=RAXX,RAOBX(3)="TX" "RTN","RAHLR1A",149,0) .S RAOBX(4)="H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L",RAOBX(12)="O" "RTN","RAHLR1A",150,0) .S RAOBX(6)=" " ;blank line to separate Reason For Study & Clin Hist "RTN","RAHLR1A",151,0) .D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLR1A",152,0) .Q "RTN","RAHLR1A",153,0) I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)) D "RTN","RAHLR1A",154,0) .S RAOBX(2)=$G(RAXX),RAOBX(3)="TX" "RTN","RAHLR1A",155,0) .S RAOBX(4)="H"_$E(HLECH)_"HISTORY"_$E(HLECH)_"L" "RTN","RAHLR1A",156,0) .;accumulate data into ^UTILITY($J,"W")... "RTN","RAHLR1A",157,0) .K ^UTILITY($J,"W") "RTN","RAHLR1A",158,0) .S DIWF="",DIWR=80,(DIWL,RADIWL)=1,RAI=0 "RTN","RAHLR1A",159,0) .F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAI)) Q:'RAI D "RTN","RAHLR1A",160,0) ..S X=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAI,0)) D ^DIWP "RTN","RAHLR1A",161,0) ..Q "RTN","RAHLR1A",162,0) .;build the OBX segment from the data in ^UTILITY($J,"W")... "RTN","RAHLR1A",163,0) .S (I,J)=0,RAOBX(12)="O" "RTN","RAHLR1A",164,0) .F S I=$O(^UTILITY($J,"W",RADIWL,I)) Q:'I D "RTN","RAHLR1A",165,0) ..S J=J+1,RAOBX(2)=RAXX+J "RTN","RAHLR1A",166,0) ..S RAOBX(6)=$$ESCAPE^RAHLRU($G(^UTILITY($J,"W",RADIWL,I,0))) "RTN","RAHLR1A",167,0) ..D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLR1A",168,0) ..Q "RTN","RAHLR1A",169,0) .S RAXX=RAOBX(2) "RTN","RAHLR1A",170,0) .Q "RTN","RAHLR1A",171,0) K DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,RADIWL,RAI,RAOBX,^UTILITY($J,"W") "RTN","RAHLR1A",172,0) ; "RTN","RAHLR1A",173,0) OBXALL ;Compile 'OBX' Segment for Allergies "RTN","RAHLR1A",174,0) N DFN S DFN=RADFN D ALLERGY^RADEM "RTN","RAHLR1A",175,0) S RAOBX(2)=$G(RAXX) "RTN","RAHLR1A",176,0) S RAOBX(3)="TX",RAOBX(4)="A"_$E(HLECH)_"ALLERGIES"_$E(HLECH)_"L" "RTN","RAHLR1A",177,0) S RAOBX(12)="O",(I,J)=0 "RTN","RAHLR1A",178,0) I $D(GMRAL)#2 D "RTN","RAHLR1A",179,0) .F S I=$O(PI(I)) Q:'I D "RTN","RAHLR1A",180,0) ..S J=J+1,FT=PI(I),RAOBX(2)=RAXX+J,RAOBX(6)=$$ESCAPE^RAHLRU(FT) "RTN","RAHLR1A",181,0) ..D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLR1A",182,0) .S RAXX=RAOBX(2) "RTN","RAHLR1A",183,0) K RAOBX "RTN","RAHLR1A",184,0) ; "RTN","RAHLR1A",185,0) OBXTCOM ;Compile 'OBX' segment for tech comments "RTN","RAHLR1A",186,0) S RAOBX(2)=$G(RAXX) "RTN","RAHLR1A",187,0) S RAOBX(3)="TX",RAOBX(4)="TCM"_$E(HLECH)_"TECH COMMENT"_$E(HLECH)_"L" "RTN","RAHLR1A",188,0) S RAOBX(12)="O",(I,J)=0 "RTN","RAHLR1A",189,0) F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",I)) Q:'I D "RTN","RAHLR1A",190,0) .S J=J+1,FT=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",I,"TCOM")) "RTN","RAHLR1A",191,0) .S RAOBX(2)=RAXX+J,RAOBX(6)=$$ESCAPE^RAHLRU(FT) "RTN","RAHLR1A",192,0) .D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLR1A",193,0) .Q "RTN","RAHLR1A",194,0) EXIT ;clean up symbol table are return to RAHLR1 "RTN","RAHLR1A",195,0) K RAOBX,RAXX,GMRAL,RAOBR,RAZCPT,RAZDIV,RAZIEN,RAZILOC,RAZITYPE,RAZMODAL "RTN","RAHLR1A",196,0) K RAZNME,RAZPHONE,RAZPMOD,RAZTMODE "RTN","RAHLR1A",197,0) Q "RTN","RAHLR1A",198,0) ; "RTN","RAHLR1A",199,0) ZDS(RADTI,RACNI,RAZDAYCS) ;Compile the 'ZDS' segment "RTN","RAHLR1A",200,0) ;Input: RADTI-inverse date/time of the examination "RTN","RAHLR1A",201,0) ; RACNI-IEN of the examination record "RTN","RAHLR1A",202,0) ; RAZDAYCS-If SSAN parameter="Y", SSAN format: sss-mmddyy-case# "RTN","RAHLR1A",203,0) ; -If SSAN'="Y" day & case# of exam, format: mmddyy-case# "RTN","RAHLR1A",204,0) ;Note: 'ZDS^MAGDRAHL' depends on the HLECH array being defined "RTN","RAHLR1A",205,0) ; "RTN","RAHLR1A",206,0) ;If the exam has a Study Instance UID defined [^DD(70.03,81)] use that "RTN","RAHLR1A",207,0) ; value to build the ZDS segment "RTN","RAHLR1A",208,0) ;If the exam does not have a Study Instance UID defined, i.e. it was "RTN","RAHLR1A",209,0) ; created before the code to build the SIUID field, then build the "RTN","RAHLR1A",210,0) ; SIUID on the fly here and use that value in the ZDS segment "RTN","RAHLR1A",211,0) ; "RTN","RAHLR1A",212,0) N I F I=1:1:$L(HLECH) S HLECH(I)=$E(HLECH,I) "RTN","RAHLR1A",213,0) ; "RTN","RAHLR1A",214,0) ;If exam has an SIUID defined use it "RTN","RAHLR1A",215,0) S RASIUID=$$GETSIUID^RAAPI(RADFN,RADTI,RACNI) I RASIUID'="" D Q "RTN","RAHLR1A",216,0) .S HLA("HLS",$$RTNSUB^RAHLRU1()+1)=$$ZDS^MAGDRAHL(RASIUID) "RTN","RAHLR1A",217,0) .F I=$O(HLECH($C(32)),-1):-1:1 K HLECH(I) ;kill array elements "RTN","RAHLR1A",218,0) ; "RTN","RAHLR1A",219,0) ;If exam does not have an SIUID defined build it here on the fly "RTN","RAHLR1A",220,0) I RASIUID="" D "RTN","RAHLR1A",221,0) .S RASIUID=$$STUDYUID^MAGDRAHL(RADTI,RACNI,RAZDAYCS) "RTN","RAHLR1A",222,0) .S HLA("HLS",$$RTNSUB^RAHLRU1()+1)=$$ZDS^MAGDRAHL(RASIUID) "RTN","RAHLR1A",223,0) F I=$O(HLECH($C(32)),-1):-1:1 K HLECH(I) ;kill array elements "RTN","RAHLR1A",224,0) Q "RTN","RAHLRPT1") 0^6^B48303444 "RTN","RAHLRPT1",1,0) RAHLRPT1 ;HISC/GJC-Compiles HL7 'ORU' Message Type ; 4/26/01 10:40am "RTN","RAHLRPT1",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21 "RTN","RAHLRPT1",3,0) ; "RTN","RAHLRPT1",4,0) ;Integration Agreements "RTN","RAHLRPT1",5,0) ;---------------------- "RTN","RAHLRPT1",6,0) ;$$GET1^DIQ(2056); ^DIWP(10011); "RTN","RAHLRPT1",7,0) ;$$FMTHL7^XLFDT(10103); $$HLNAME^XLFNAME(3065) "RTN","RAHLRPT1",8,0) ; "RTN","RAHLRPT1",9,0) EN(RADFN,RADTI,RACNI,RAEID) ;Called from all RA RPT* event driver protocols whose "RTN","RAHLRPT1",10,0) ;HL7 version exceeds version 2.3. "RTN","RAHLRPT1",11,0) ; "RTN","RAHLRPT1",12,0) ;Input Variables (from RAHLRPT): "RTN","RAHLRPT1",13,0) ; RADFN=file 2 IEN (DFN) "RTN","RAHLRPT1",14,0) ; RADTI=file 70 Exam subrec IEN (inverse date/time of exam) "RTN","RAHLRPT1",15,0) ; RACNI=file 70 Case subrecord IEN "RTN","RAHLRPT1",16,0) ; RAEID=ien of the event driver protocol (defined in RAHLRPC) "RTN","RAHLRPT1",17,0) ;Output variables: "RTN","RAHLRPT1",18,0) ; HLA("HLS", array containing HL7 msg "RTN","RAHLRPT1",19,0) ; "RTN","RAHLRPT1",20,0) ;Note: RAOBR(n+1) = OBR 'n' because our software begins "RTN","RAHLRPT1",21,0) ;building the segment with the segment header ('OBR') "RTN","RAHLRPT1",22,0) ; "RTN","RAHLRPT1",23,0) ;new some variables... "RTN","RAHLRPT1",24,0) N %,DN,FT,I,J,PTR,X,Y "RTN","RAHLRPT1",25,0) ;initialize Rad/Nuc Med specific variables "RTN","RAHLRPT1",26,0) D INIT^RAHLR1 "RTN","RAHLRPT1",27,0) PID ;Compile the 'PID' segment "RTN","RAHLRPT1",28,0) D PID^RAHLRU1(RADFN) "RTN","RAHLRPT1",29,0) OBR ;Compile 'OBR' Segment "RTN","RAHLRPT1",30,0) ;get pointer value to the rad/nuc med report; needed to build the OBR "RTN","RAHLRPT1",31,0) S RAZRPT=+$P(RAZXAM,U,17) "RTN","RAHLRPT1",32,0) ;get rad/nuc med report zero node & the transcriptionist (if exists) "RTN","RAHLRPT1",33,0) S RAZRPT=$G(^RARPT(RAZRPT,0)),RAZTRANS=+$G(^RARPT(+$P(RAZXAM,U,17),"T")) "RTN","RAHLRPT1",34,0) ;Set ID OBR-1 "RTN","RAHLRPT1",35,0) S RAOBR(2)=1 "RTN","RAHLRPT1",36,0) ;Placer Order Number OBR-2 mmddyy-case# "RTN","RAHLRPT1",37,0) ;Filler Order Number OBR-3 mmddyy-case# "RTN","RAHLRPT1",38,0) S (RAOBR(3),RAOBR(4))=RAZDAYCS "RTN","RAHLRPT1",39,0) S RAZCPT=$P(RAZPROC,U,9),RAZCPT(0)=$$NAMCODE^RACPTMSC(RAZCPT,DT) "RTN","RAHLRPT1",40,0) ;RAZCPT(0)=CPT code from file 81^short name of CPT code from file 81 "RTN","RAHLRPT1",41,0) ;RAOBR(4)=CPT code #81_comp sep_CPT code short name #81_comp sep_"C4" "RTN","RAHLRPT1",42,0) ; _comp sep_IEN file #71_comp sep_procedure name #71_comp sep_ "RTN","RAHLRPT1",43,0) ; "99RAP" "RTN","RAHLRPT1",44,0) ; "RTN","RAHLRPT1",45,0) S RAOBR(5)=$P(RAZCPT(0),U)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAZCPT(0),U,2))_$E(HLECH)_"C4" "RTN","RAHLRPT1",46,0) S RAOBR(5)=RAOBR(5)_$E(HLECH)_+$P(RAZXAM,U,2)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAZPROC,U))_$E(HLECH)_"99RAP" "RTN","RAHLRPT1",47,0) ;Observation date/time OBR-7 (DATE REPORT ENTERED) 74;6 "RTN","RAHLRPT1",48,0) S RAOBR(8)=$$FMTHL7^XLFDT($P(RAZRPT,U,6)) "RTN","RAHLRPT1",49,0) ;Specimen Source OBR-15 75.1;125 PROCEDURE MODIFIERS (mult: 75.1125) "RTN","RAHLRPT1",50,0) ;(left & right only) "RTN","RAHLRPT1",51,0) S RAZPMOD=$$SPECSRC^RAHLRU1(+$P(RAZXAM,U,11)) "RTN","RAHLRPT1",52,0) S:$L(RAZPMOD) RAOBR(16)=$$REPEAT^RAHLRU1($E(HLECH),4)_$E(HLECH,4)_RAZPMOD "RTN","RAHLRPT1",53,0) ; "RTN","RAHLRPT1",54,0) ;Ordering Provider OBR-16 (REQUESTING PHYSICIAN) 75.1;14 "RTN","RAHLRPT1",55,0) I $P(RAZORD,U,14),($$GET1^DIQ(200,$P(RAZORD,U,14),.01)'="") D "RTN","RAHLRPT1",56,0) .K RAZNME S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZORD,U,14) "RTN","RAHLRPT1",57,0) .S RAZNME("FIELD")=.01 "RTN","RAHLRPT1",58,0) .S RAOBR(17)=$P(RAZORD,U,14)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1)) "RTN","RAHLRPT1",59,0) .Q "RTN","RAHLRPT1",60,0) ; "RTN","RAHLRPT1",61,0) ;Call Back Phone numbers of Ordering Provider OBR-17 "RTN","RAHLRPT1",62,0) D "RTN","RAHLRPT1",63,0) .N RAX,I,M S M="",I=0 "RTN","RAHLRPT1",64,0) .D NPFON^MAG7UFO("RAX",$P(RAZORD,U,14)) "RTN","RAHLRPT1",65,0) .F S I=$O(RAX(I)) Q:'I S M=M_$$ESCAPE^RAHLRU($G(RAX(I,1,1)))_$E(HLECH)_$G(RAX(I,2,1))_$E(HLECH)_$G(RAX(I,3,1))_$E(HLECH,2) "RTN","RAHLRPT1",66,0) .S:$L(M) RAOBR(18)=$E(M,1,$L(M)-1) "RTN","RAHLRPT1",67,0) ; "RTN","RAHLRPT1",68,0) ;Placer Field 1 OBR-18 site id-mmddyy-case# (mirrors OBR-2 & OBR-3) "RTN","RAHLRPT1",69,0) S RAOBR(19)=RAZDAYCS "RTN","RAHLRPT1",70,0) ; "RTN","RAHLRPT1",71,0) ;Placer Field 2 definition has been changed by a VistA Imaging request "RTN","RAHLRPT1",72,0) ;-> prior to 07/2007: inv. date/time of the exam concatenated to (by the "RTN","RAHLRPT1",73,0) ; dash) the exam record IEN (Placer Fld 2 OBR-19 = Filler Fld 1 OBR-20) "RTN","RAHLRPT1",74,0) ;-> after 07/2007: case number "RTN","RAHLRPT1",75,0) ;RAZDAYCS=sss-mmddyy-case# OR mmddyy-case# "RTN","RAHLRPT1",76,0) S RAOBR(20)=$P(RAZDAYCS,"-",$L(RAZDAYCS,"-")) "RTN","RAHLRPT1",77,0) ; "RTN","RAHLRPT1",78,0) ;Filler Field 1 OBR-20 is defined as the site specific accession number: "RTN","RAHLRPT1",79,0) ;site id-mmddyy-case# Note: same value as OBR-18, OBR-2, & OBR-3 "RTN","RAHLRPT1",80,0) ;(change effective 07/2007) "RTN","RAHLRPT1",81,0) S RAOBR(21)=RAZDAYCS "RTN","RAHLRPT1",82,0) ; "RTN","RAHLRPT1",83,0) ;Filler Field 2 OBR-21 (change effective 07/2007) "RTN","RAHLRPT1",84,0) ;RAZRXAM defined in INIT^RAHLR1 "RTN","RAHLRPT1",85,0) S RAOBR(22)=$$OBR21^RAHLRU(HLECH,RAZRXAM) "RTN","RAHLRPT1",86,0) ; "RTN","RAHLRPT1",87,0) ;Results Rpt/Status Chng-date/time OBR-22 "RTN","RAHLRPT1",88,0) ;verified: VERIFIED DATE 74;7 "RTN","RAHLRPT1",89,0) ;unv'fied: DATE REPORT ENTERED 74;6 "RTN","RAHLRPT1",90,0) S:$P(RAZRPT,U,5)="V" RAOBR(23)=$$FMTHL7^XLFDT($P(RAZRPT,U,7)) "RTN","RAHLRPT1",91,0) S:$P(RAZRPT,U,5)'="V" RAOBR(23)=$$FMTHL7^XLFDT($P(RAZRPT,U,6)) "RTN","RAHLRPT1",92,0) ;Status OBR-25 REPORT STATUS 74;5 "RTN","RAHLRPT1",93,0) ;S:$D(^RARPT(+$P(RAZXAM,U,17),"ERR",1,0))#2 RAOBR(26)="C" ;corrected rt "RTN","RAHLRPT1",94,0) S:'$D(RAOBR(26))#2 RAOBR(26)=$S(($P(RAZRPT,U,5)="V")!($P(RAZRPT,U,5)="EF"):"F",1:"R") ;"EF" reports send "F" (Final) in OBR-25 "RTN","RAHLRPT1",95,0) ;Parent OBR-29 70.03;25 if exam/printset find ordered parent procedure "RTN","RAHLRPT1",96,0) I $P(RAZXAM,U,25) D ;is this case part of an examset/printset "RTN","RAHLRPT1",97,0) .S RAOBR(30)=$S($P(RAZXAM,U,25)=1:"Examset: ",1:"Printset: ")_$P($G(^RAMIS(71,+$P(RAZORD,U,2),0)),U) "RTN","RAHLRPT1",98,0) .Q "RTN","RAHLRPT1",99,0) ;Principal Result Interpreter OBR-32 70.03;15 "RTN","RAHLRPT1",100,0) I $P(RAZXAM,U,15),($$GET1^DIQ(200,$P(RAZXAM,U,15),.01)'="") D "RTN","RAHLRPT1",101,0) .K RAZNME S RAZNME("FILE")=200,RAZNME("IENS")=$P(RAZXAM,U,15) "RTN","RAHLRPT1",102,0) .S RAZNME("FIELD")=.01 "RTN","RAHLRPT1",103,0) .;S RAOBR(33)=$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1)) "RTN","RAHLRPT1",104,0) .S RAOBR(33)=$P(RAZXAM,U,15)_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1)) "RTN","RAHLRPT1",105,0) .Q "RTN","RAHLRPT1",106,0) ;Assistant Result Interpreter(s)/contributors OBR-33 70.03;12 "RTN","RAHLRPT1",107,0) N CNT,RAI,RAJ S CNT=0 "RTN","RAHLRPT1",108,0) I $P(RAZXAM,U,12),($$GET1^DIQ(200,$P(RAZXAM,U,12),.01)'="") D "RTN","RAHLRPT1",109,0) .K RAZNME D INTNAM($P(RAZXAM,U,12)) "RTN","RAHLRPT1",110,0) .Q "RTN","RAHLRPT1",111,0) K RAZNME F RAI="SRR","SSR" D Q:CNT=10 ;ten or less interpreters "RTN","RAHLRPT1",112,0) .S RAJ=0 "RTN","RAHLRPT1",113,0) .F S RAJ=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,RAI,RAJ)) Q:'RAJ S RAJ(0)=+$G(^(RAJ,0)) D Q:CNT=10 "RTN","RAHLRPT1",114,0) ..D INTNAM(RAJ(0)) "RTN","RAHLRPT1",115,0) ..Q "RTN","RAHLRPT1",116,0) .Q "RTN","RAHLRPT1",117,0) ;Transcriptionist OBR-35 74;11 "RTN","RAHLRPT1",118,0) I RAZTRANS,($$GET1^DIQ(200,RAZTRANS,.01)'="") D "RTN","RAHLRPT1",119,0) .S RAZNME("FILE")=200,RAZNME("IENS")=RAZTRANS,RAZNME("FIELD")=.01 "RTN","RAHLRPT1",120,0) .S RAOBR(36)=RAZTRANS_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1)) K RAZNME "RTN","RAHLRPT1",121,0) .Q "RTN","RAHLRPT1",122,0) ; "RTN","RAHLRPT1",123,0) ;build the OBR segment "RTN","RAHLRPT1",124,0) D BLSEG^RAHLRU1("OBR",.RAOBR) "RTN","RAHLRPT1",125,0) ; "RTN","RAHLRPT1",126,0) ;build the ZDS segment "RTN","RAHLRPT1",127,0) D ZDS^RAHLR1A(RADTI,RACNI,RAZDAYCS) "RTN","RAHLRPT1",128,0) ; "RTN","RAHLRPT1",129,0) OBXPRC ;Compile 'OBX' Segment for Procedure "RTN","RAHLRPT1",130,0) ;RAXX = Counter in segment "RTN","RAHLRPT1",131,0) S (RAOBX(2),RAXX)=1 "RTN","RAHLRPT1",132,0) S RAOBX(3)="CE",RAOBX(4)="P"_$E(HLECH)_"PROCEDURE"_$E(HLECH)_"L" "RTN","RAHLRPT1",133,0) S RAOBX(6)=$P(RAZXAM,U,2)_$E(HLECH)_$$ESCAPE^RAHLRU($P($G(^RAMIS(71,+$P(RAZXAM,U,2),0)),U))_$E(HLECH)_"L" "RTN","RAHLRPT1",134,0) S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17)) "RTN","RAHLRPT1",135,0) D BLSEG^RAHLRU1("OBX",.RAOBX) K RAOBX "RTN","RAHLRPT1",136,0) ; "RTN","RAHLRPT1",137,0) OBXIMP ;Compile the 'OBX' segment for Impression Text "RTN","RAHLRPT1",138,0) S RAOBX(2)=$G(RAXX) "RTN","RAHLRPT1",139,0) I $O(^RARPT(+$P(RAZXAM,U,17),"I",0)) D "RTN","RAHLRPT1",140,0) .S RAOBX(3)="TX",RAOBX(4)="I"_$E(HLECH)_"IMPRESSION"_$E(HLECH)_"L" "RTN","RAHLRPT1",141,0) .S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17)) "RTN","RAHLRPT1",142,0) .K ^UTILITY($J,"W") S DIWF="",DIWR=75,(DIWL,RADIWL)=1 "RTN","RAHLRPT1",143,0) .S RAI=0 F S RAI=$O(^RARPT(+$P(RAZXAM,U,17),"I",RAI)) Q:'RAI D "RTN","RAHLRPT1",144,0) ..S X=$G(^RARPT(+$P(RAZXAM,U,17),"I",RAI,0)) D ^DIWP "RTN","RAHLRPT1",145,0) ..Q "RTN","RAHLRPT1",146,0) .S (RAI,RAJ)=0 F S RAI=$O(^UTILITY($J,"W",RADIWL,RAI)) Q:'RAI D "RTN","RAHLRPT1",147,0) ..S RAJ=RAJ+1,RAOBX(2)=RAXX+RAJ "RTN","RAHLRPT1",148,0) ..S RAOBX(6)=$$ESCAPE^RAHLRU($G(^UTILITY($J,"W",RADIWL,RAI,0))) "RTN","RAHLRPT1",149,0) ..D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLRPT1",150,0) ..Q "RTN","RAHLRPT1",151,0) .S RAXX=$G(RAOBX(2)) "RTN","RAHLRPT1",152,0) .Q "RTN","RAHLRPT1",153,0) K DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,RADIWL,RAOBX,^UTILITY($J,"W") "RTN","RAHLRPT1",154,0) ; "RTN","RAHLRPT1",155,0) OBXDX ;Compile the 'OBX' segment for Diagnostic Code "RTN","RAHLRPT1",156,0) S RAOBX(2)=$G(RAXX) "RTN","RAHLRPT1",157,0) I +$P(RAZXAM,U,13) D ;pri. Dx code exists; look for secondary Dx "RTN","RAHLRPT1",158,0) .S RAOBX(2)=RAXX+1,RAOBX(3)="CE" "RTN","RAHLRPT1",159,0) .S RAOBX(4)="D"_$E(HLECH)_"DIAGNOSTIC CODE"_$E(HLECH)_"L" "RTN","RAHLRPT1",160,0) .S RAOBX(6)=+$P(RAZXAM,U,13)_$E(HLECH)_$$ESCAPE^RAHLRU($P($G(^RA(78.3,+$P(RAZXAM,U,13),0)),U))_$E(HLECH)_"L" "RTN","RAHLRPT1",161,0) .S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17)) "RTN","RAHLRPT1",162,0) .D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLRPT1",163,0) .S RAXX=$G(RAOBX(2)) "RTN","RAHLRPT1",164,0) .Q "RTN","RAHLRPT1",165,0) I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) D ;secondaries... "RTN","RAHLRPT1",166,0) .S RAI=0,RAJ=0 "RTN","RAHLRPT1",167,0) .F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RAI)) Q:'RAI D "RTN","RAHLRPT1",168,0) ..S RAPTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RAI,0)) "RTN","RAHLRPT1",169,0) ..S RAFT=$P($G(^RA(78.3,RAPTR,0)),U) "RTN","RAHLRPT1",170,0) ..S RAJ=RAJ+1,RAOBX(2)=RAXX+RAJ,RAOBX(6)=RAPTR_$E(HLECH)_$$ESCAPE^RAHLRU(RAFT)_$E(HLECH)_"L" "RTN","RAHLRPT1",171,0) ..D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLRPT1",172,0) ..Q "RTN","RAHLRPT1",173,0) .S RAXX=$G(RAOBX(2)) "RTN","RAHLRPT1",174,0) .Q "RTN","RAHLRPT1",175,0) K RAFT,RAOBX,RAPTR "RTN","RAHLRPT1",176,0) ; "RTN","RAHLRPT1",177,0) OBXPMOD ;Compile 'OBX' segment for procedure modifiers "RTN","RAHLRPT1",178,0) S RAOBX(2)=$G(RAXX),RAJ=0 "RTN","RAHLRPT1",179,0) S RAOBX(3)="TX",RAOBX(4)="M"_$E(HLECH)_"MODIFIERS"_$E(HLECH)_"L" "RTN","RAHLRPT1",180,0) S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17)),(RAI,RAJ)=0 "RTN","RAHLRPT1",181,0) F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",RAI)) Q:'RAI D "RTN","RAHLRPT1",182,0) .S RAJ=RAJ+1,RAPTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",RAI,0)) "RTN","RAHLRPT1",183,0) .S RAOBX(2)=RAXX+RAJ "RTN","RAHLRPT1",184,0) .S RAOBX(6)=$$ESCAPE^RAHLRU($P($G(^RAMIS(71.2,RAPTR,0)),U)) "RTN","RAHLRPT1",185,0) .D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLRPT1",186,0) .Q "RTN","RAHLRPT1",187,0) S RAXX=$G(RAOBX(2)) "RTN","RAHLRPT1",188,0) K RAOBX,RAPTR "RTN","RAHLRPT1",189,0) ; "RTN","RAHLRPT1",190,0) OBXTCOM ;Compile 'OBX' segment for tech comments "RTN","RAHLRPT1",191,0) D OBXTCOM^RAHLRPT2 "RTN","RAHLRPT1",192,0) ; "RTN","RAHLRPT1",193,0) OBXCPTM ;Compile 'OBX' segment for CPT modifiers "RTN","RAHLRPT1",194,0) D OBXCPTM^RAHLRPT2 "RTN","RAHLRPT1",195,0) ; "RTN","RAHLRPT1",196,0) OBXRPT ;Compile 'OBX' segment for Report Text "RTN","RAHLRPT1",197,0) D OBXRPT^RAHLRPT2 "RTN","RAHLRPT1",198,0) ; "RTN","RAHLRPT1",199,0) ;Broadcast the HL7 message and cleanup the symbol table "RTN","RAHLRPT1",200,0) D GENERATE^RAHLRU "RTN","RAHLRPT1",201,0) Q "RTN","RAHLRPT1",202,0) ; "RTN","RAHLRPT1",203,0) INTNAM(Y) ;return the name of the intepreter(s) "RTN","RAHLRPT1",204,0) ; input: Y=IEN of the record in the New Person (#200) file "RTN","RAHLRPT1",205,0) ; CNT=second level subscript is newed,initialized and checked above "RTN","RAHLRPT1",206,0) S RAZNME("FILE")=200,RAZNME("IENS")=Y,RAZNME("FIELD")=.01 "RTN","RAHLRPT1",207,0) S CNT=CNT+1 ;update counter by 1 "RTN","RAHLRPT1",208,0) S RAOBR(34,CNT)=Y_$E(HLECH)_$$HLNAME^XLFNAME(.RAZNME,"S",$E(HLECH,1)) K RAZNME "RTN","RAHLRPT1",209,0) Q "RTN","RAHLRPT2") 0^8^B7037276 "RTN","RAHLRPT2",1,0) RAHLRPT2 ;HISC/GJC-Compiles HL7 'ORU' Message Type ; 4/26/01 10:40am "RTN","RAHLRPT2",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21 "RTN","RAHLRPT2",3,0) ; "RTN","RAHLRPT2",4,0) ;called from RAHLRPT1 "RTN","RAHLRPT2",5,0) ; "RTN","RAHLRPT2",6,0) ;Integration Agreements "RTN","RAHLRPT2",7,0) ;---------------------- "RTN","RAHLRPT2",8,0) ; ^DIWP(10011) "RTN","RAHLRPT2",9,0) ; "RTN","RAHLRPT2",10,0) OBXTCOM ;Compile 'OBX' segment for tech comments "RTN","RAHLRPT2",11,0) S RAOBX(2)=$G(RAXX) "RTN","RAHLRPT2",12,0) S RAOBX(3)="TX",RAOBX(4)="TCM"_$E(HLECH)_"TECH COMMENT"_$E(HLECH)_"L" "RTN","RAHLRPT2",13,0) S RAOBX(12)=$$OBX11(+$P(RAZXAM,U,17)),(RAI,RAJ)=0 "RTN","RAHLRPT2",14,0) F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RAI)) Q:'RAI D "RTN","RAHLRPT2",15,0) .Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RAI,"TCOM")) "RTN","RAHLRPT2",16,0) .S RAJ=RAJ+1,RAFT=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RAI,"TCOM")) "RTN","RAHLRPT2",17,0) .S RAOBX(2)=$G(RAXX)+RAJ,RAOBX(6)=$$ESCAPE^RAHLRU(RAFT) "RTN","RAHLRPT2",18,0) .D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLRPT2",19,0) .Q "RTN","RAHLRPT2",20,0) S RAXX=$G(RAOBX(2)) "RTN","RAHLRPT2",21,0) K RAFT,RAOBX Q "RTN","RAHLRPT2",22,0) ; "RTN","RAHLRPT2",23,0) OBXCPTM ;Compile 'OBX' segment for CPT modifiers "RTN","RAHLRPT2",24,0) S RAOBX(2)=$G(RAXX) "RTN","RAHLRPT2",25,0) S RAOBX(3)="CE",RAOBX(4)="C4"_$E(HLECH)_"CPT MODIFIERS"_$E(HLECH)_"L" "RTN","RAHLRPT2",26,0) S RAOBX(12)=$$OBX11(+$P(RAZXAM,U,17)),(RAI,RAJ)=0 "RTN","RAHLRPT2",27,0) F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RAI)) Q:'RAI D "RTN","RAHLRPT2",28,0) .S RAJ=RAJ+1,RAPTR=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RAI,0)) "RTN","RAHLRPT2",29,0) .S RAOBX(2)=RAXX+RAJ,RAOBX(6)=$$CPTMOD^RAHLRU(RAPTR,HLECH,DT) "RTN","RAHLRPT2",30,0) .D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLRPT2",31,0) .Q "RTN","RAHLRPT2",32,0) S RAXX=$G(RAOBX(2)) "RTN","RAHLRPT2",33,0) Q "RTN","RAHLRPT2",34,0) ; "RTN","RAHLRPT2",35,0) OBXRPT ;Compile the 'OBX' segment for Report Text "RTN","RAHLRPT2",36,0) S RAOBX(2)=$G(RAXX) "RTN","RAHLRPT2",37,0) I $O(^RARPT(+$P(RAZXAM,U,17),"R",0)) D "RTN","RAHLRPT2",38,0) .S RAOBX(3)="TX",RAOBX(4)="R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L" "RTN","RAHLRPT2",39,0) .S RAOBX(12)=$$OBX11^RAHLRPT2(+$P(RAZXAM,U,17)) "RTN","RAHLRPT2",40,0) .K ^UTILITY($J,"W") S DIWF="",DIWR=75,(DIWL,RADIWL)=1 "RTN","RAHLRPT2",41,0) .S RAI=0 F S RAI=$O(^RARPT(+$P(RAZXAM,U,17),"R",RAI)) Q:'RAI D "RTN","RAHLRPT2",42,0) ..S X=$G(^RARPT(+$P(RAZXAM,U,17),"R",RAI,0)) D ^DIWP "RTN","RAHLRPT2",43,0) ..Q "RTN","RAHLRPT2",44,0) .S (RAI,RAJ)=0 F S RAI=$O(^UTILITY($J,"W",RADIWL,RAI)) Q:'RAI D "RTN","RAHLRPT2",45,0) ..S RAJ=RAJ+1,RAOBX(2)=RAXX+RAJ "RTN","RAHLRPT2",46,0) ..S RAOBX(6)=$$ESCAPE^RAHLRU($G(^UTILITY($J,"W",RADIWL,RAI,0))) "RTN","RAHLRPT2",47,0) ..D BLSEG^RAHLRU1("OBX",.RAOBX) "RTN","RAHLRPT2",48,0) ..Q "RTN","RAHLRPT2",49,0) .S RAXX=$G(RAOBX(2)) "RTN","RAHLRPT2",50,0) .Q "RTN","RAHLRPT2",51,0) K DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,RADIWL,RAOBX,^UTILITY($J,"W") "RTN","RAHLRPT2",52,0) Q "RTN","RAHLRPT2",53,0) ; "RTN","RAHLRPT2",54,0) OBX11(RARPT) ;set OBX-11 (Observ. Rslt Status) correctly "RTN","RAHLRPT2",55,0) ;input : RARPT =IEN of the RAD/NUC MED REPORT record "RTN","RAHLRPT2",56,0) ; RAZRPT=zero node of the RAD/NUC MED REPORT record "RTN","RAHLRPT2",57,0) ;return: OBX-11 (as 'Y') "RTN","RAHLRPT2",58,0) Q:RARPT=0 "" "RTN","RAHLRPT2",59,0) N Y S:$D(^RARPT(RARPT,"ERR",1,0))#2 Y="C" ;corrected result "RTN","RAHLRPT2",60,0) S:'$D(Y)#2 Y=$S(($P(^RARPT(RARPT,0),U,5)="V")!($P(^RARPT(RARPT,0),U,5)="EF"):"F",1:"R") ;"EF" reports send "F" (Final) in OBX-11 "RTN","RAHLRPT2",61,0) ;S:'$D(Y)#2 Y=$S($P(^RARPT(RARPT,0),U,5)="V":"F",1:"R") "RTN","RAHLRPT2",62,0) Q Y "RTN","RAHLRPT2",63,0) ; "RTN","RAHLRS1") 0^66^B62793760 "RTN","RAHLRS1",1,0) RAHLRS1 ;HIRMFO/ROB/PAVEL/GJC - Resend HL7 messages for selected Timeframe ; 10/27/08 11:01 "RTN","RAHLRS1",2,0) ;;5.0;Radiology/Nuclear Medicine;**80,84,95,47**;Mar 16, 1998;Build 21 "RTN","RAHLRS1",3,0) ; Utility to RESEND HL7 messages for selected Timeframe "RTN","RAHLRS1",4,0) ; "RTN","RAHLRS1",5,0) ;Integration Agreements "RTN","RAHLRS1",6,0) ;---------------------- "RTN","RAHLRS1",7,0) ;^%DT(10003); C^%DTC(10000); H^%DTC(10000); ^%ZISC(10089); ^%ZTLOAD(10063); $$GET1^DIQ(2056) "RTN","RAHLRS1",8,0) ;^DIR(10026); ^XMD(10070) "RTN","RAHLRS1",9,0) ;all access to ^ORD(101 to maintain application specific protocols(872) "RTN","RAHLRS1",10,0) ;read w/FileMan HL7 APPLICATION PARAMETER(10136) "RTN","RAHLRS1",11,0) ; "RTN","RAHLRS1",12,0) N RACNI,RADFN,RADTI,RARPT,X,RAED,RABD,RASHBD,RASHED,RASHTD,RASHTM,DIC,DA,XX,YY "RTN","RAHLRS1",13,0) N RALOCK,RASSS,RASSSX,RASSSL,I,X S RALOCK=0 "RTN","RAHLRS1",14,0) CHECK ; "RTN","RAHLRS1",15,0) D SETVARS Q:$G(RAIMGTY)="" "RTN","RAHLRS1",16,0) W !!,"This option re-sends HL7 messages for a date range and for designated Recipients.",! "RTN","RAHLRS1",17,0) W !,"It is strongly recommended you task this to run off hours.",!! "RTN","RAHLRS1",18,0) S:'$D(U) U="^" S:'$D(DTIME) DTIME=9999 "RTN","RAHLRS1",19,0) 1 W ! K %DT S %DT="AEX",%DT("A")="Beginning Date: " D ^%DT "RTN","RAHLRS1",20,0) G:Y<0!($D(DTOUT))!($D(DUOUT)) STOP "RTN","RAHLRS1",21,0) S RABD=Y "RTN","RAHLRS1",22,0) X ^DD("DD") S RASHBD=Y "RTN","RAHLRS1",23,0) S X1=RABD,X2=-1 D C^%DTC S RABD=X "RTN","RAHLRS1",24,0) S RABD=RABD_"."_9999 "RTN","RAHLRS1",25,0) ; "RTN","RAHLRS1",26,0) W ! K %DT S %DT="AEX",%DT("A")="Ending Date: ",%DT("B")="NOW" D ^%DT "RTN","RAHLRS1",27,0) G:Y<0!($D(DTOUT))!($D(DUOUT)) STOP "RTN","RAHLRS1",28,0) S RAED=Y "RTN","RAHLRS1",29,0) X ^DD("DD") S RASHED=Y "RTN","RAHLRS1",30,0) S RAED=RAED_"."_9999 "RTN","RAHLRS1",31,0) K XX G:'$$GETAP(.XX) STOP "RTN","RAHLRS1",32,0) W !!,"*** Pick the application in which to send the radiology data ***",!! "RTN","RAHLRS1",33,0) F I=1:1 Q:'$D(XX(I)) W !," #",I," ",$O(XX(I,"")) "RTN","RAHLRS1",34,0) 2 ;user selects the application "RTN","RAHLRS1",35,0) S DIR(0)="N^1:"_(I-1) "RTN","RAHLRS1",36,0) W ! S DIR("?")="Please select an available application from the list." "RTN","RAHLRS1",37,0) D ^DIR Q:$D(DIRUT) "RTN","RAHLRS1",38,0) W !!,"The: ",$O(XX(+X,""))," will be the recipient" "RTN","RAHLRS1",39,0) W !!,"Reviewing exams for selected time period... (This may take a few minutes)... " "RTN","RAHLRS1",40,0) S Y=$$GETSUM(RABD,RAED) "RTN","RAHLRS1",41,0) I 'Y W !!,"No exams exist for selected period, change the time frame !!!" H 3 W ! G 1 "RTN","RAHLRS1",42,0) W !!,"During this period of time ",Y," Exams were performed and app Run time= ",Y\5000," Hours." "RTN","RAHLRS1",43,0) S RAPICK=$O(XX(+X,"")) ;appl. recipient name, RA*5*95 "RTN","RAHLRS1",44,0) S RASSS(XX(X,$O(XX(+X,""))))="" D GETSUB(.RASSS,.RASSSX,.RASSSL) "RTN","RAHLRS1",45,0) K ZTSAVE "RTN","RAHLRS1",46,0) S ZTSAVE("RAOPT(")="" ;RAOPT("RESEND DT") set/killed in entry/exit action fields on option p47 "RTN","RAHLRS1",47,0) S ZTSAVE("RAPICK")="" ;include appl. recipient name in task, RA*5*95 "RTN","RAHLRS1",48,0) S ZTSAVE("RASSSX(")="",ZTSAVE("RASSSL(")="",ZTSAVE("RABD")="",ZTSAVE("RAED")="",ZTSAVE("RADFN")="" "RTN","RAHLRS1",49,0) S ZTSAVE("RADTI")="",ZTSAVE("RACNI")="",ZTSAVE("RASHBD")="",ZTSAVE("RASHED")="",ZTIO="" "RTN","RAHLRS1",50,0) S ZTDESC="Rad/Nuc Med Compiling HL7 Common Order",ZTRTN="TM^RAHLRS1" "RTN","RAHLRS1",51,0) W ! K %DT S %DT="AEXT",%DT("A")="Scheduled time to run: ",%DT("B")="TODAY@23:59" D ^%DT "RTN","RAHLRS1",52,0) G:Y<0!($D(DTOUT))!($D(DUOUT)) STOP "RTN","RAHLRS1",53,0) S X=Y,YY=Y D H^%DTC S ZTDTH=$G(%H)_","_$G(%T) "RTN","RAHLRS1",54,0) S Y=YY X ^DD("DD") S RASHTM=Y "RTN","RAHLRS1",55,0) D ^%ZTLOAD "RTN","RAHLRS1",56,0) W !,"Task ",$S('$D(ZTSK):" Has Not been Tasked !!!",1:"#:"_ZTSK_" Has been Tasked") "RTN","RAHLRS1",57,0) D:$D(ZTSK) "RTN","RAHLRS1",58,0) .N RAX,RAMPG,XMSUB,XMY,XMTEXT "RTN","RAHLRS1",59,0) .S RAX(1)="Task #"_$G(ZTSK)_" is scheduled to run the option: " "RTN","RAHLRS1",60,0) .S RAX(2)=">>Re-send HL7 messages for a date range and for designated Recipient.<<" "RTN","RAHLRS1",61,0) .S RAX(3)=" Scheduled time to run: "_RASHTM "RTN","RAHLRS1",62,0) .S RAX(4)="Date range from: "_$G(RASHBD)_" to: "_$G(RASHED) "RTN","RAHLRS1",63,0) .S XMSUB="TASKMAN SCHEDULE NOTIFICATION/INFO" "RTN","RAHLRS1",64,0) .S RAMPG="G.RAD HL7 MESSAGES" "RTN","RAHLRS1",65,0) .S XMY(RAMPG)="",XMDUZ=.5 "RTN","RAHLRS1",66,0) .S XMTEXT="RAX(" "RTN","RAHLRS1",67,0) .D ^XMD "RTN","RAHLRS1",68,0) Q "RTN","RAHLRS1",69,0) ; "RTN","RAHLRS1",70,0) TM ;Taskman Entry... "RTN","RAHLRS1",71,0) N RASTIME,RASUM7,RASUM7R,RASUM7E "RTN","RAHLRS1",72,0) S RASTIME=$H,(RASUM7,RASUM7R,RASUM7E)=0 "RTN","RAHLRS1",73,0) F S RABD=$O(^RADPT("AR",RABD)) Q:'RABD!(RABD>RAED) D "RTN","RAHLRS1",74,0) .S RADFN=0 F S RADFN=$O(^RADPT("AR",RABD,RADFN)) Q:'RADFN D "RTN","RAHLRS1",75,0) ..S RADTI=0 F S RADTI=$O(^RADPT("AR",RABD,RADFN,RADTI)) Q:'RADTI D "RTN","RAHLRS1",76,0) ...S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI D RESEND(RADFN,RADTI,RACNI) "RTN","RAHLRS1",77,0) K RAX S RAX(1)="Task #"_$G(ZTSK)_" successfully completed the option: " "RTN","RAHLRS1",78,0) S RAX(2)=">>Re-send HL7 messages for a date range and for designated Recipient.<<" "RTN","RAHLRS1",79,0) S RAX(3)="Date range from: "_$G(RASHBD)_" to: "_$G(RASHED) "RTN","RAHLRS1",80,0) S RAX(4)="# Of RAD Reports transferred: "_$G(RASUM7R) "RTN","RAHLRS1",81,0) S RAX(5)="# Of Exams transferred: "_$G(RASUM7) "RTN","RAHLRS1",82,0) S:$G(RASUM7E) X(6)="# Of Exams not transferred because of ""BAD DATA"": "_$G(RASUM7E) "RTN","RAHLRS1",83,0) S XMSUB="TASKMAN ""RESEND HL7 OPTION"" COMPLETED/INFO" "RTN","RAHLRS1",84,0) S RAMPG="G.RAD HL7 MESSAGES" "RTN","RAHLRS1",85,0) S XMY(RAMPG)="",XMDUZ=.5 "RTN","RAHLRS1",86,0) S XMTEXT="RAX(" "RTN","RAHLRS1",87,0) D ^XMD "RTN","RAHLRS1",88,0) G STOP "RTN","RAHLRS1",89,0) Q "RTN","RAHLRS1",90,0) ; "RTN","RAHLRS1",91,0) RESEND(RADFN,RADTI,RACNI) ; re-send exam message(s) to HL7 subscribers "RTN","RAHLRS1",92,0) ; for every 10 messages sent, make sure queue is not clogged... $$HANG "RTN","RAHLRS1",93,0) N RAXAMP80 S RAXAMP80=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) "RTN","RAHLRS1",94,0) I '(+$P(RAXAMP80,U))!'($P(RAXAMP80,U,2)) S RASUM7E=RASUM7E+1 Q "RTN","RAHLRS1",95,0) N RABD,RAEDP80,QUIT,RARPST ;added RARPST, RA*5*95 "RTN","RAHLRS1",96,0) ; "RTN","RAHLRS1",97,0) I '$D(DT) D ^%DT S DT=Y "RTN","RAHLRS1",98,0) ; "RTN","RAHLRS1",99,0) S RAEDP80=$$RAED(RADFN,RADTI,RACNI) "RTN","RAHLRS1",100,0) I '$L(RAEDP80) S RASUM7E=RASUM7E+1 Q "RTN","RAHLRS1",101,0) D:RAEDP80[",REG," "RTN","RAHLRS1",102,0) .D CHSUM N RASUM7,RASUM7R,RASUM7E D REG^RAHLRPC "RTN","RAHLRS1",103,0) D:RAEDP80[",CANCEL," "RTN","RAHLRS1",104,0) .D CHSUM N RASUM7,RASUM7R,RASUM7E D CANCEL^RAHLRPC "RTN","RAHLRS1",105,0) D:RAEDP80[",EXAM," "RTN","RAHLRS1",106,0) .D CHSUM "RTN","RAHLRS1",107,0) .S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",30)="" ;Reset sent flag "RTN","RAHLRS1",108,0) .N RASUM7,RAEXMDUN,RASUM7R,RASUM7E D 1^RAHLRPC "RTN","RAHLRS1",109,0) ;if EF report and recipient is VR, then don't re-send, RA*5*95 "RTN","RAHLRS1",110,0) I RARPST="EF",((RAPICK["RA-TALK")!(RAPICK["RA-PSCRIBE")!(RAPICK["RA-SCIMAGE")!(RAPICK["RA-RADWHERE")) Q "RTN","RAHLRS1",111,0) D:RAEDP80[",RPT," "RTN","RAHLRS1",112,0) .D CHSUM N RASUM7,RANOSEND,RASUM7R,RASUM7E,RARPT D RPT^RAHLRPC "RTN","RAHLRS1",113,0) Q "RTN","RAHLRS1",114,0) ; "RTN","RAHLRS1",115,0) RAED(RADFN,RADTI,RACNI) ; identify correct ^RAHLRPC entry point(s) "RTN","RAHLRS1",116,0) ; "RTN","RAHLRS1",117,0) N RASTAT,RAIMTYP,RAORD,RETURN,RARPT "RTN","RAHLRS1",118,0) S RASTAT="" "RTN","RAHLRS1",119,0) ; "RTN","RAHLRS1",120,0) S RETURN=",REG," "RTN","RAHLRS1",121,0) ; "RTN","RAHLRS1",122,0) S RASTAT=$$GET1^DIQ(70.03,RACNI_","_RADTI_","_RADFN,3,"I") "RTN","RAHLRS1",123,0) S RARPT=$$GET1^DIQ(70.03,RACNI_","_RADTI_","_RADFN,17,"I") "RTN","RAHLRS1",124,0) ; "RTN","RAHLRS1",125,0) S RAIMTYP=$$GET1^DIQ(72,+RASTAT,7) Q:'$L(RAIMTYP) "" "RTN","RAHLRS1",126,0) S RAORD=$$GET1^DIQ(72,+RASTAT,3) "RTN","RAHLRS1",127,0) ; "RTN","RAHLRS1",128,0) S:RAORD=0 RETURN=RETURN_"CANCEL," "RTN","RAHLRS1",129,0) ; "RTN","RAHLRS1",130,0) S:$$GET1^DIQ(72,+RASTAT,8)="YES" RETURN=RETURN_"EXAM," ; Generate Examined HL7 Message "RTN","RAHLRS1",131,0) ; "RTN","RAHLRS1",132,0) D:RETURN'[",EXAM," "RTN","RAHLRS1",133,0) .; also check previous statuses for 'Generate Examined HL7 Message' "RTN","RAHLRS1",134,0) .F S RAORD=$O(^RA(72,"AA",RAIMTYP,RAORD),-1) Q:+RAORD<1 D Q:RETURN[",EXAM," "RTN","RAHLRS1",135,0) ..S RASTAT=$O(^RA(72,"AA",RAIMTYP,RAORD,0)) "RTN","RAHLRS1",136,0) ..S:$$GET1^DIQ(72,+RASTAT,8)="YES" RETURN=RETURN_"EXAM," "RTN","RAHLRS1",137,0) ; "RTN","RAHLRS1",138,0) ; Check if Verified or Elec. Filed report exists ;RA*5*95 "RTN","RAHLRS1",139,0) S RARPST=$$GET1^DIQ(74,RARPT_",",5,"I") "RTN","RAHLRS1",140,0) I RARPT]"",("^V^EF^"[("^"_RARPST_"^")) S RETURN=RETURN_"RPT,",RASUM7R=RASUM7R+1 "RTN","RAHLRS1",141,0) ; "RTN","RAHLRS1",142,0) Q RETURN "RTN","RAHLRS1",143,0) ; "RTN","RAHLRS1",144,0) SETVARS ; Setup key Rad/Nuc Med variables "RTN","RAHLRS1",145,0) ; "RTN","RAHLRS1",146,0) I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) "RTN","RAHLRS1",147,0) Q:'($D(RACCESS(DUZ))\10) ; user does not have location access "RTN","RAHLRS1",148,0) I $G(RAIMGTY)="" D SETVARS^RAPSET1(1) K:$G(RAIMGTY)="" XQUIT "RTN","RAHLRS1",149,0) Q "RTN","RAHLRS1",150,0) STOP ; "RTN","RAHLRS1",151,0) D ^%ZISC "RTN","RAHLRS1",152,0) Q "RTN","RAHLRS1",153,0) ; "RTN","RAHLRS1",154,0) GETAP(XX) ; "RTN","RAHLRS1",155,0) ;Get list of Applications in XX "RTN","RAHLRS1",156,0) N XXX,X11,X1,X2,X3,Z,Z1,J "RTN","RAHLRS1",157,0) F X11="RA REG","RA EXAMINED","RA CANCEL","RA RPT" D "RTN","RAHLRS1",158,0) .S X1=$E(X11,1,$L(X11)-1)_$C($A($E(X11,$L(X11)))-1) "RTN","RAHLRS1",159,0) .F S X1=$O(^ORD(101,"B",X1)) Q:X1'[X11 S X2=$O(^ORD(101,"B",X1,0)) Q:'X2 D "RTN","RAHLRS1",160,0) ..K Z S X3=0 F S X3=$O(^ORD(101,X2,775,X3)) Q:'X3 S Z(+^(X3,0))="" "RTN","RAHLRS1",161,0) ..Q:'$D(Z) K Z1 S X3=0 F S X3=$O(Z(X3)) Q:'X3 D "RTN","RAHLRS1",162,0) ...S Z1=$G(^ORD(101,X3,770)) S:+$P(Z1,U,2) XXX(+$P(Z1,U,2))="" "RTN","RAHLRS1",163,0) S X1=0 F J=1:1 S X1=$O(XXX(X1)) Q:'X1 D "RTN","RAHLRS1",164,0) .N DIERR,RAERR,Y "RTN","RAHLRS1",165,0) .S Y=$$GET1^DIQ(771,X1,.01,"","","RAERR") "RTN","RAHLRS1",166,0) .Q:Y=""!($D(RAERR)#2) S XX(J,Y)=X1 "RTN","RAHLRS1",167,0) .Q "RTN","RAHLRS1",168,0) Q $S($D(XXX):1,1:0) "RTN","RAHLRS1",169,0) ; "RTN","RAHLRS1",170,0) GETSUB(APL,SUB,LINK) ;Get all subscribers (not associated with application)... To be excluded as recipients.. "RTN","RAHLRS1",171,0) ; Get all logical links to be in business, so we can control flow of messages "RTN","RAHLRS1",172,0) ;Set up SUB() of 4 Radiology protocol IENS in file #101 that "RTN","RAHLRS1",173,0) ;are NOT associated with applications defined in APL() "RTN","RAHLRS1",174,0) ; "RTN","RAHLRS1",175,0) ;INPUT: "RTN","RAHLRS1",176,0) ;APL(IEN) = Application #771 IENs "RTN","RAHLRS1",177,0) ; "RTN","RAHLRS1",178,0) ;OUTPUT: "RTN","RAHLRS1",179,0) ;SUB(Event Driver #101 IEN,Subscriber #101 IEN)=.01 in file #101 "RTN","RAHLRS1",180,0) ;LINK(IEN of logical link #870) "RTN","RAHLRS1",181,0) ; "RTN","RAHLRS1",182,0) N XX,X11,X1,X2,X3 "RTN","RAHLRS1",183,0) Q:'$O(APL(0)) "RTN","RAHLRS1",184,0) F X11="RA REG","RA EXAMINED","RA CANCEL","RA RPT" D "RTN","RAHLRS1",185,0) .S X1=$E(X11,1,$L(X11)-1)_$C($A($E(X11,$L(X11)))-1) "RTN","RAHLRS1",186,0) .F S X1=$O(^ORD(101,"B",X1)) Q:X1'[X11 S X2=$O(^ORD(101,"B",X1,0)) Q:'X2 D "RTN","RAHLRS1",187,0) ..S X3=0 F S X3=$O(^ORD(101,X2,775,X3)) Q:'X3 S XX=+^(X3,0) D "RTN","RAHLRS1",188,0) ...I '$D(APL(+$P($G(^ORD(101,XX,770)),U,2))) S SUB(X2,XX)=X1 Q "RTN","RAHLRS1",189,0) ...S XX=+$P($G(^ORD(101,XX,770)),U,7) S:XX LINK(XX)="" "RTN","RAHLRS1",190,0) Q "RTN","RAHLRS1",191,0) GETHLP(RAEID,HLP,ADR) ; Get excluded subcribers set into HLP array "RTN","RAHLRS1",192,0) N I,J,XX,AA S J=$O(HLP("EXCLUDE SUBSCRIBER",99999999),-1) "RTN","RAHLRS1",193,0) ;XX Set the list of already excluded subscribers, so be sure we don't set it second time "RTN","RAHLRS1",194,0) S AA=ADR_"("_RAEID_",I)" "RTN","RAHLRS1",195,0) S I=0 F I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I S XX(HLP("EXCLUDE SUBSCRIBER",I))="" "RTN","RAHLRS1",196,0) S I=0 F S I=$O(@AA) Q:'I S:'$D(XX(I)) J=J+1,HLP("EXCLUDE SUBSCRIBER",J)=I "RTN","RAHLRS1",197,0) Q "RTN","RAHLRS1",198,0) CHSUM ;CHECKSUM "RTN","RAHLRS1",199,0) S RASUM7=RASUM7+1 I '(RASUM7#50) F Q:'$$HANG H 15 "RTN","RAHLRS1",200,0) Q "RTN","RAHLRS1",201,0) HANG() ; scan all logical links to see if queue is bigger than 100 "RTN","RAHLRS1",202,0) N I,S,L,QUIT "RTN","RAHLRS1",203,0) S (QUIT,L)=0 "RTN","RAHLRS1",204,0) F S L=$O(RASSSL(L)) Q:'L S (S,I)=0 D Q:QUIT "RTN","RAHLRS1",205,0) .F S I=$O(^HLMA("AC","O",L,I)) Q:'I S S=S+1 I S>100 S QUIT=1 Q ;Quit if more than 100 messages waiting in outgoing queue for link... "RTN","RAHLRS1",206,0) Q QUIT "RTN","RAHLRS1",207,0) GETSUM(RABD,RAED) ; Get number of exams for period called from RAHLR RAHLR1 RAHLRPT RAHLRPT1 "RTN","RAHLRS1",208,0) N RADFN,RADTI,RACNI,RASUM7 "RTN","RAHLRS1",209,0) S RASUM7=0 "RTN","RAHLRS1",210,0) F S RABD=$O(^RADPT("AR",RABD)) Q:'RABD!(RABD>RAED) D "RTN","RAHLRS1",211,0) .S RADFN=0 F S RADFN=$O(^RADPT("AR",RABD,RADFN)) Q:'RADFN D "RTN","RAHLRS1",212,0) ..S RADTI=0 F S RADTI=$O(^RADPT("AR",RABD,RADFN,RADTI)) Q:'RADTI D "RTN","RAHLRS1",213,0) ...S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI S:^(RACNI,0) RASUM7=RASUM7+1 "RTN","RAHLRS1",214,0) Q RASUM7 "RTN","RAHLRS1",215,0) Q "RTN","RAHLRU") 0^2^B44912236 "RTN","RAHLRU",1,0) RAHLRU ;HISC/GJC - utilities for HL7 messaging ;03/16/98 11:03 "RTN","RAHLRU",2,0) ;;5.0;Radiology/Nuclear Medicine;**10,25,81,103,47**;Mar 16, 1998;Build 21 "RTN","RAHLRU",3,0) ; "RTN","RAHLRU",4,0) ; 08/13/2010 BP/KAM RA*5*103 Outside Report Status Code needs 'F' "RTN","RAHLRU",5,0) ;Integration Agreements "RTN","RAHLRU",6,0) ;---------------------- "RTN","RAHLRU",7,0) ;$$GET1^DIQ(2056); $$HLDATE^HLFNC(10106); INIT^HLFNC2(2161) "RTN","RAHLRU",8,0) ;GENERATE^HLMA(2164); $$NOW^XLFDT(10103); $$PATCH^XPDUTL(10141) "RTN","RAHLRU",9,0) ;$$VERSION^XPDUTL(10141) "RTN","RAHLRU",10,0) ; "RTN","RAHLRU",11,0) ;IA: global read .01 field, file ^HL(771, "RTN","RAHLRU",12,0) ;IA: global read .01 field, file ^HL(771.2, "RTN","RAHLRU",13,0) ;IA: global read .01 field, file ^HL(771.5, "RTN","RAHLRU",14,0) ;IA: global read .01 field, file ^HL(779.001, "RTN","RAHLRU",15,0) ; "RTN","RAHLRU",16,0) OBX11 ; set OBX-11, = 12th piece of string where piece 1 is "OBX" "RTN","RAHLRU",17,0) N RARPTIEN,Y "RTN","RAHLRU",18,0) S RARPTIEN=+$G(RARPT) "RTN","RAHLRU",19,0) S Y=$P($G(^RARPT(RARPTIEN,0)),U,5) "RTN","RAHLRU",20,0) ; 08/13/2010 BP/KAM RA*5*103 Remedy Call 363538 Changed next line to "RTN","RAHLRU",21,0) ; test for 'EF' or 'V' "RTN","RAHLRU",22,0) ;S $P(HLA("HLS",RAN),HLFS,12)=$S(Y="R":"P",Y="V":"F",1:"I") "RTN","RAHLRU",23,0) S $P(HLA("HLS",RAN),HLFS,12)=$S(Y="R":"P",(Y="V")!(Y="EF"):"F",1:"I") "RTN","RAHLRU",24,0) ; END *103 CHANGE "RTN","RAHLRU",25,0) I $D(^RARPT(RARPTIEN,"ERR")) D Q "RTN","RAHLRU",26,0) .S $P(HLA("HLS",RAN),HLFS,12)="C" "RTN","RAHLRU",27,0) Q "RTN","RAHLRU",28,0) ; "RTN","RAHLRU",29,0) ESCAPE(XDTA) ;apply the appropriate escape sequence to a string of data "RTN","RAHLRU",30,0) ; Insert a escape sequence place holder, then swap the escape sequence "RTN","RAHLRU",31,0) ; place holder with the real escape sequence. This action requires two "RTN","RAHLRU",32,0) ; passes because the escape sequence uses the escape ("\") character. "RTN","RAHLRU",33,0) ; Input: XDTA=data string to be escaped (if necessary) "RTN","RAHLRU",34,0) ; HLFS=field separator (global scope; set in INIT^RAHLR) "RTN","RAHLRU",35,0) ; HLECH=encoding characters (global scope; set in INIT^RAHLR) "RTN","RAHLRU",36,0) ; Return: XDTA=an escaped data string "RTN","RAHLRU",37,0) ; "RTN","RAHLRU",38,0) N UFS,UCS,URS,UEC,USS ;field, component, repetition, escape, & subcomponent "RTN","RAHLRU",39,0) S UFS=HLFS,UCS=$E(HLECH),URS=$E(HLECH,2),UEC=$E(HLECH,3),USS=$E(HLECH,4) "RTN","RAHLRU",40,0) F Q:XDTA'[UFS S XDTA=$P(XDTA,UFS)_$C(1)_$P(XDTA,UFS,2,999) "RTN","RAHLRU",41,0) F Q:XDTA'[UCS S XDTA=$P(XDTA,UCS)_$C(2)_$P(XDTA,UCS,2,999) "RTN","RAHLRU",42,0) F Q:XDTA'[URS S XDTA=$P(XDTA,URS)_$C(3)_$P(XDTA,URS,2,999) "RTN","RAHLRU",43,0) F Q:XDTA'[UEC S XDTA=$P(XDTA,UEC)_$C(4)_$P(XDTA,UEC,2,999) "RTN","RAHLRU",44,0) F Q:XDTA'[USS S XDTA=$P(XDTA,USS)_$C(5)_$P(XDTA,USS,2,999) "RTN","RAHLRU",45,0) F Q:XDTA'[$C(1) S XDTA=$P(XDTA,$C(1))_UEC_"F"_UEC_$P(XDTA,$C(1),2,999) "RTN","RAHLRU",46,0) F Q:XDTA'[$C(2) S XDTA=$P(XDTA,$C(2))_UEC_"S"_UEC_$P(XDTA,$C(2),2,999) "RTN","RAHLRU",47,0) F Q:XDTA'[$C(3) S XDTA=$P(XDTA,$C(3))_UEC_"R"_UEC_$P(XDTA,$C(3),2,999) "RTN","RAHLRU",48,0) F Q:XDTA'[$C(4) S XDTA=$P(XDTA,$C(4))_UEC_"E"_UEC_$P(XDTA,$C(4),2,999) "RTN","RAHLRU",49,0) F Q:XDTA'[$C(5) S XDTA=$P(XDTA,$C(5))_UEC_"T"_UEC_$P(XDTA,$C(5),2,999) "RTN","RAHLRU",50,0) Q XDTA "RTN","RAHLRU",51,0) ; "RTN","RAHLRU",52,0) OBXPRC ;Compile 'OBX' Segment for Procedure "RTN","RAHLRU",53,0) S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"P"_$E(HLECH)_"PROCEDURE"_$E(HLECH)_"L"_HLFS_HLFS_$P(RACN0,"^",2) "RTN","RAHLRU",54,0) S X=$S($D(^RAMIS(71,+$P(RACN0,"^",2),0)):$P(^(0),"^"),1:""),HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_X_$E(HLECH)_"L" D OBX11 "RTN","RAHLRU",55,0) ; Replace above with following when Imaging can cope with ESC chars "RTN","RAHLRU",56,0) ; S X=$S($D(^RAMIS(71,+$P(RACN0,"^",2),0)):$P(^(0),"^"),1:""),HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_$$ESCAPE(X)_$E(HLECH)_"L" D OBX11 "RTN","RAHLRU",57,0) Q "RTN","RAHLRU",58,0) OBXMOD ; Compile 'OBX' segments for both types of modifiers "RTN","RAHLRU",59,0) ; Procedure modifiers "RTN","RAHLRU",60,0) N X3 "RTN","RAHLRU",61,0) D MODS^RAUTL2 S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"M"_$E(HLECH)_"MODIFIERS"_$E(HLECH)_"L"_HLFS_HLFS_Y D OBX11 "RTN","RAHLRU",62,0) Q:Y(1)="None" "RTN","RAHLRU",63,0) ; CPT Modifiers "RTN","RAHLRU",64,0) F RAI=1:1 S X0=$P(Y(1),", ",RAI),X1=$P(Y(2),", ",RAI) Q:X0="" D "RTN","RAHLRU",65,0) . S RAN=RAN+1 "RTN","RAHLRU",66,0) . S X3=$$BASICMOD^RACPTMSC(X1,DT) "RTN","RAHLRU",67,0) . S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"C4"_$E(HLECH)_"CPT MODIFIERS"_$E(HLECH)_"C4"_HLFS_HLFS_X0_$E(HLECH)_$P(X3,"^",3)_$E(HLECH)_"C4" "RTN","RAHLRU",68,0) . ; Replace above with following when Imaging can cope with ESC chars "RTN","RAHLRU",69,0) . ;S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"CE"_HLFS_"C4"_$E(HLECH)_"CPT MODIFIERS"_$E(HLECH)_"C4"_HLFS_HLFS_X0_$E(HLECH)_$$ESCAPE($P(X3,"^",3))_$E(HLECH)_"C4" "RTN","RAHLRU",70,0) . I $P(X3,"^",4)]"" S HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_$P(X3,"^",4)_$E(HLECH)_$P(X3,"^",3)_$E(HLECH)_"C4" "RTN","RAHLRU",71,0) . ; Replace above with following when Imaging can cope with ESC chars "RTN","RAHLRU",72,0) . ;I $P(X3,"^",4)]"" S HLA("HLS",RAN)=HLA("HLS",RAN)_$E(HLECH)_$P(X3,"^",4)_$E(HLECH)_$$ESCAPE($P(X3,"^",3))_$E(HLECH)_"C4" "RTN","RAHLRU",73,0) . D OBX11 "RTN","RAHLRU",74,0) . Q "RTN","RAHLRU",75,0) Q "RTN","RAHLRU",76,0) ; "RTN","RAHLRU",77,0) OBXTCM ; Compile 'OBX' segment for latest TECH COMMENT "RTN","RAHLRU",78,0) ; "RTN","RAHLRU",79,0) ; Only Released version of Imaging 2.5 able to handle Tech Comments "RTN","RAHLRU",80,0) Q:'($$PATCH^XPDUTL("MAG*2.5*1")!(+$$VERSION^XPDUTL("MAG")>2.5)) "RTN","RAHLRU",81,0) ; "RTN","RAHLRU",82,0) N X4,X3 "RTN","RAHLRU",83,0) S X4=$$GETTCOM^RAUTL11(RADFN,RADTI,RACNI) "RTN","RAHLRU",84,0) Q:X4="" "RTN","RAHLRU",85,0) S RAN=RAN+1 "RTN","RAHLRU",86,0) S HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"TCM"_$E(HLECH)_"TECH COMMENT"_$E(HLECH)_"L"_HLFS_HLFS "RTN","RAHLRU",87,0) D OBX11 "RTN","RAHLRU",88,0) I $L(X4)+$L(HLA("HLS",RAN))'>245 D Q "RTN","RAHLRU",89,0) .S $P(HLA("HLS",RAN),HLFS,6)=X4 "RTN","RAHLRU",90,0) ; "RTN","RAHLRU",91,0) ; If Tech Comment is v. long it will need to be "RTN","RAHLRU",92,0) ; split into two parts. Do not split words if possible.... "RTN","RAHLRU",93,0) ; "RTN","RAHLRU",94,0) S X3=$E(X4,1,245-$L(HLA("HLS",RAN))) "RTN","RAHLRU",95,0) I $L(X3," ")>1 S X3=$P(X3," ",1,$L(X3," ")-1) "RTN","RAHLRU",96,0) S X4=$P(X4,X3,2) "RTN","RAHLRU",97,0) S $P(HLA("HLS",RAN),HLFS,6)=X3 "RTN","RAHLRU",98,0) S HLA("HLS",RAN,1)=X4_HLFS_$P(HLA("HLS",RAN),HLFS,7,12) "RTN","RAHLRU",99,0) S HLA("HLS",RAN)=$P(HLA("HLS",RAN),HLFS,1,6) "RTN","RAHLRU",100,0) Q "RTN","RAHLRU",101,0) ; "RTN","RAHLRU",102,0) INIT ; initialize HL7 variables; called from RAHLR & RAHLRPT "RTN","RAHLRU",103,0) Q:'$G(RAEID) ;undefined server application "RTN","RAHLRU",104,0) S HLDT=$$NOW^XLFDT(),HLDT1=$$HLDATE^HLFNC(HLDT),EID=RAEID "RTN","RAHLRU",105,0) S HL="HLS(""HLS"")",INT=1 "RTN","RAHLRU",106,0) D INIT^HLFNC2(EID,.HL,INT) "RTN","RAHLRU",107,0) Q:'$D(HL("Q")) ;improperly defined server application "RTN","RAHLRU",108,0) S HLQ=HL("Q"),HLFS=HL("FS"),HLECH=HL("ECH") K EID,INT "RTN","RAHLRU",109,0) S HLCS=$E(HL("ECH")) "RTN","RAHLRU",110,0) S HLSCS=$E(HL("ECH"),4) "RTN","RAHLRU",111,0) S HLREP=$E(HL("ECH"),2) "RTN","RAHLRU",112,0) Q "RTN","RAHLRU",113,0) ; "RTN","RAHLRU",114,0) DOB(X) ;strip off trailing "0"'s from the date of birth "RTN","RAHLRU",115,0) I $E(X,5,6)="00" S X=$E(X,1,4) ;if no month then no day, return year "RTN","RAHLRU",116,0) E I $E(X,7,8)="00" S X=$E(X,1,6) ;if month & no day, return month/year "RTN","RAHLRU",117,0) Q X "RTN","RAHLRU",118,0) ; "RTN","RAHLRU",119,0) CPTMOD(RAIEN,HLECH,DT) ;return OBX-5 as it pertains to CPT Modifiers "RTN","RAHLRU",120,0) ;called from: RAHLRPT2 & RAHLR1A "RTN","RAHLRU",121,0) ;input: RAIEN=IEN of the record in file 81.3 "RTN","RAHLRU",122,0) ; HLECH=HL7 encoding characters "RTN","RAHLRU",123,0) ; DT=today's date "RTN","RAHLRU",124,0) N X S X=$$BASICMOD^RACPTMSC(RAIEN,DT) "RTN","RAHLRU",125,0) ;1st piece=IEN #81.3; 3rd piece=versioned name; 5th piece=coding sys "RTN","RAHLRU",126,0) ;Q RAIEN_$E(HLECH,1)_$$ESCAPE^RAHLRU($P(X,U,3))_$E(HLECH,1)_$P(X,U,5) "RTN","RAHLRU",127,0) ;9/5/08 the above line changed to below per IMAGING "RTN","RAHLRU",128,0) Q $P(X,U,2)_$E(HLECH,1)_$$ESCAPE^RAHLRU($P(X,U,3))_$E(HLECH,1)_"C4" "RTN","RAHLRU",129,0) ; "RTN","RAHLRU",130,0) GETSFLAG(SAN,MTN,ETN,VER) ;Return HL message flag (79.721,1) "RTN","RAHLRU",131,0) Q:'$L(SAN)!'$L(MTN)!'$L(ETN)!'$L(VER) 0 "RTN","RAHLRU",132,0) S SAN=$O(^HL(771,"B",SAN,0)) Q:'SAN 0 "RTN","RAHLRU",133,0) S MTN=$O(^HL(771.2,"B",MTN,0)) Q:'MTN 0 "RTN","RAHLRU",134,0) S ETN=$O(^HL(779.001,"B",ETN,0)) Q:'ETN 0 "RTN","RAHLRU",135,0) S VER=$O(^HL(771.5,"B",VER,0)) Q:'VER 0 "RTN","RAHLRU",136,0) Q +$P($G(^RA(79.7,SAN,1,MTN,1,ETN,1,VER,0)),U,2) "RTN","RAHLRU",137,0) ; "RTN","RAHLRU",138,0) OBR21(HLECH,RA7002) ;builds the OBR-21 field; called from RAHLR1A "RTN","RAHLRU",139,0) ;Input "RTN","RAHLRU",140,0) ; HLECH=encoding characters (required for $$ESCAPE^RAHLRU) "RTN","RAHLRU",141,0) ; RA7002=zero node of the REGISTERED EXAMS sub-file of the RAD/NUC MED "RTN","RAHLRU",142,0) ; PATIENT (#70) file. "RTN","RAHLRU",143,0) ;Return: "RTN","RAHLRU",144,0) ; Component one (derived from file #79.2) "RTN","RAHLRU",145,0) ; ABBREVIATION(#3)_NAME(#.01) "RTN","RAHLRU",146,0) ; Component two (derived from file #79.1) "RTN","RAHLRU",147,0) ; File 79.1 IEN_NAME(#.01) of the HOSPITAL LOCATION(#44) record. "RTN","RAHLRU",148,0) ; Component three (derived from file #79) "RTN","RAHLRU",149,0) ; DIVISION(#.01)_NAME(#.01) of the INSTITUTION(#4) record. "RTN","RAHLRU",150,0) ; "RTN","RAHLRU",151,0) ;Components as separated by the accent grave "`" (RAPCS); subcomponents by the "RTN","RAHLRU",152,0) ;underscore "_" (RAPSS) "RTN","RAHLRU",153,0) ; "RTN","RAHLRU",154,0) ; Ex: RAD_GENERAL RADIOLOGY`1_TD-RAD`660_SALT LAKE CITY "RTN","RAHLRU",155,0) ; "RTN","RAHLRU",156,0) N RAX S RAPCS="`",RAPSS="_",RAX="" "RTN","RAHLRU",157,0) S RA792Q=+$P(RA7002,U,2) ;imaging type pointer "RTN","RAHLRU",158,0) S RA792Q(0)=$G(^RA(79.2,RA792Q,0)) ;imaging type zero node "RTN","RAHLRU",159,0) ;create the i-type abbreviation, component separator, and full name string "RTN","RAHLRU",160,0) S RAX=$P(RA792Q(0),U,3)_RAPSS_$P(RA792Q(0),U) "RTN","RAHLRU",161,0) ;get hospital location and institution file data... "RTN","RAHLRU",162,0) S RA791Q=+$P(RA7002,U,4) ;imaging location pointer "RTN","RAHLRU",163,0) S RA44Q=+$P($G(^RA(79.1,RA791Q,0)),U) ;hospital location pointer "RTN","RAHLRU",164,0) S RA44Q(0)=$$GET1^DIQ(44,RA44Q,.01) ;hospital location name "RTN","RAHLRU",165,0) S RA4Q=+$P(RA7002,U,3) ;rad/nuc med division pointer dinum'd to INSTITUTION (#4) file "RTN","RAHLRU",166,0) S RA4Q(0)=$$GET1^DIQ(4,RA4Q,.01) ;institution name "RTN","RAHLRU",167,0) S RAX=RAX_RAPCS_RA791Q_RAPSS_RA44Q(0)_RAPCS_RA4Q_RAPSS_RA4Q(0) "RTN","RAHLRU",168,0) K RA4Q,RA44Q,RA791Q,RA792Q,RAPCS,RAPSS "RTN","RAHLRU",169,0) Q $$ESCAPE^RAHLRU(RAX) "RTN","RAHLRU",170,0) ; "RTN","RAHLRU",171,0) GENERATE ;Broadcast the HL7 message (courtesy of the VistA HL7 application) "RTN","RAHLRU",172,0) N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP "RTN","RAHLRU",173,0) S HLEID=RAEID,HLARYTYP="LM",HLFORMAT=1,HLMTIEN="",HLP("PRIORITY")="I" "RTN","RAHLRU",174,0) ;D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX") "RTN","RAHLRU",175,0) D GENERATE^HLMA(RAEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP) "RTN","RAHLRU",176,0) D GSTATUS^RAHLACK(.HLRESLT,RAEID) K HLRESLT "RTN","RAHLRU",177,0) ; "RTN","RAHLRU",178,0) EXIT ;kill the variables; exit the process... "RTN","RAHLRU",179,0) K HL771RF,HL771SF,HL7STRG,HLA,HLARYTYP,HLCS,HLDOM,HLECH,HLEID,HLES,HLES2,HLFORMAT "RTN","RAHLRU",180,0) K HLFS,HLINSTN,HLMTIEN,HLN,HLP,HLPARAM,HLPID,HLQ,HLREC,HLREP,HLRFREQ,HLSAN,HLSCS "RTN","RAHLRU",181,0) K HLSFREQ,HLTYPE,HLX,OCXSEG,OCXTSPI,RAOBR,RAORC,RAPID,RAPURGE,RAPV1,RAREFDOC,RAZCPT "RTN","RAHLRU",182,0) K RAZDAYCS,RAZDTE,RAZMODE,RAZNME,RAZORD,RAZORD1,RAZPHONE,RAZPMOD,RAZPREG,RAZPROC "RTN","RAHLRU",183,0) K RAZRPT,RAZRXAM,RAZTRANS,RAZXAM,HLRESLT "RTN","RAHLRU",184,0) K ^UTILITY($J,"W") ;note HLCS, HLREP, & HLSCS are set in INIT^RAHLRU "RTN","RAHLRU",185,0) Q "RTN","RAHLRU",186,0) ; "RTN","RAHLRU1") 0^14^B76146976 "RTN","RAHLRU1",1,0) RAHLRU1 ;HISC/PB,GJC - utilities for HL7 messaging ;1/28/00 11:03 "RTN","RAHLRU1",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21 "RTN","RAHLRU1",3,0) ; "RTN","RAHLRU1",4,0) ;IA 5023: builds the PID ($$PID^MAGDHLS) & PV1 ($$PV1^MAGDHLS) segments "RTN","RAHLRU1",5,0) ;Integration Agreements "RTN","RAHLRU1",6,0) ;---------------------- "RTN","RAHLRU1",7,0) ;$$GET1^DIQ(2056); $$HLDATE^HLFNC(10106); M11^HLFNC(10106) "RTN","RAHLRU1",8,0) ;GENERATE^HLMA(2164); $$PID^MAGDHLS(5023); $$PV1^MAGDHLS(5023) "RTN","RAHLRU1",9,0) ;$$DT^XLFDT(10103); $$LOW^XLFSTR(10104) "RTN","RAHLRU1",10,0) ; "RTN","RAHLRU1",11,0) ;IA: 10060 global of file ^VA(200 "RTN","RAHLRU1",12,0) ; "RTN","RAHLRU1",13,0) PID(RADFN) ;compile the PID segment "RTN","RAHLRU1",14,0) ;$$PID^MAGDHLS(XDFN,XYMSG) "RTN","RAHLRU1",15,0) ; input: XDFN internal entry number of the patient on global ^DPT/^RADPT "RTN","RAHLRU1",16,0) ; XYMSG name of array to which to add message elts "RTN","RAHLRU1",17,0) ; output: @XYMSG input array plus new subtree containing PV1 elts "RTN","RAHLRU1",18,0) ; function return 0 (success) always "RTN","RAHLRU1",19,0) ; "RTN","RAHLRU1",20,0) K RA0X S X=$$PID^MAGDHLS(RADFN,"RA0X") "RTN","RAHLRU1",21,0) D MAG(.RA0X,.RAPID) "RTN","RAHLRU1",22,0) D BLSEG("PID",.RAPID) K RA0X "RTN","RAHLRU1",23,0) Q "RTN","RAHLRU1",24,0) ; "RTN","RAHLRU1",25,0) PV1(RADFN) ;compile the PV1 segment determine if the patient is "RTN","RAHLRU1",26,0) ;an inpatient or outpatient by looking at the exam record "RTN","RAHLRU1",27,0) ;$$PV1^MAGDHLS(XDFN,XEVN,XEVNDT,XYMSG) "RTN","RAHLRU1",28,0) ; input: XDFN internal entry number of the patient on global ^DPT/^RADPT "RTN","RAHLRU1",29,0) ; XEVN event type of this message "RTN","RAHLRU1",30,0) ; XEVNDT event date/time (FileMan format) "RTN","RAHLRU1",31,0) ; XYMSG name of array to which to add message elts "RTN","RAHLRU1",32,0) ; output: @XYMSG input array plus new subtree containing PV1 elts "RTN","RAHLRU1",33,0) ; function return 0 (success) always "RTN","RAHLRU1",34,0) K RA0X S X=$$PV1^MAGDHLS(RADFN,"O01",RAZDTE,"RA0X") "RTN","RAHLRU1",35,0) D MAG(.RA0X,.RAPV1) "RTN","RAHLRU1",36,0) K:RAPV1(3)="O"&($G(RAPV1(20))=0) RAPV1(20) "RTN","RAHLRU1",37,0) ; "RTN","RAHLRU1",38,0) ;After call to MAG API add PV1-15: Ambulatory Status of the patient "RTN","RAHLRU1",39,0) ;MODE OF TRANSPORT - file: 75.1, field: 19, node: 0, piece: 19 "RTN","RAHLRU1",40,0) ;'a' FOR AMBULATORY; 'p' FOR PORTABLE; "RTN","RAHLRU1",41,0) ;'s' FOR STRETCHER; 'w' FOR WHEEL CHAIR; "RTN","RAHLRU1",42,0) ; "RTN","RAHLRU1",43,0) ;'a' translates to 'A0', 's' & 'w' translate to 'A2' "RTN","RAHLRU1",44,0) ; "RTN","RAHLRU1",45,0) ;PREGNANT - first check field (70.03,32) if NULL check field (75.1,13) "RTN","RAHLRU1",46,0) ; file: 70.03, field: 32, node: 0, piece: 32 "RTN","RAHLRU1",47,0) ; 'y' FOR 'Patient answered yes' "RTN","RAHLRU1",48,0) ; 'n' FOR 'Patient answered no' "RTN","RAHLRU1",49,0) ; 'u' FOR 'Patient is unable to answer or is unsure' "RTN","RAHLRU1",50,0) ; file: 75.1, field: 13, node: 0, piece: 13 "RTN","RAHLRU1",51,0) ; 'y' FOR YES; 'n' FOR NO; 'u' FOR UNKNOWN; "RTN","RAHLRU1",52,0) ; "RTN","RAHLRU1",53,0) ;'y' in either field translates to 'B6' "RTN","RAHLRU1",54,0) ; "RTN","RAHLRU1",55,0) ;PV1(15) might repeat; $E(HLECH,2) is the repeat character "RTN","RAHLRU1",56,0) ;PV1(15) represented by RAPV1(16) "RTN","RAHLRU1",57,0) S RAZPREG=$P($G(RAZXAM),U,32) I RAZPREG="" S RAZPREG=$P($G(RAZORD),U,13) "RTN","RAHLRU1",58,0) S RAZMODE=$P($G(RAZORD),U,19) "RTN","RAHLRU1",59,0) S RAPV1(16)=$S(RAZMODE="a":"A0",RAZMODE="s":"A2",RAZMODE="w":"A2",1:"") "RTN","RAHLRU1",60,0) I RAPV1(16)]"",RAZPREG="y" D "RTN","RAHLRU1",61,0) .S RAPV1(16)=RAPV1(16)_$E(HLECH,2)_"B6" "RTN","RAHLRU1",62,0) .Q "RTN","RAHLRU1",63,0) E I RAPV1(16)="",RAZPREG="y" S RAPV1(16)="B6" "RTN","RAHLRU1",64,0) ; "RTN","RAHLRU1",65,0) D BLSEG("PV1",.RAPV1) K RA0X "RTN","RAHLRU1",66,0) Q "RTN","RAHLRU1",67,0) ; "RTN","RAHLRU1",68,0) REPEAT(X,N) ;return a string of HL7 encoding characters; ideal when a field "RTN","RAHLRU1",69,0) ;is comprised of many components "RTN","RAHLRU1",70,0) ;input: X=character repeated; for example, the component delimiter "RTN","RAHLRU1",71,0) ; N=string length of the character "RTN","RAHLRU1",72,0) ;rturn: S=string in question "RTN","RAHLRU1",73,0) N S S $P(S,X,(N+1))="" "RTN","RAHLRU1",74,0) Q S "RTN","RAHLRU1",75,0) ; "RTN","RAHLRU1",76,0) MAG(XX,RAD) ;Build the HL7 segment from the array passed back from the "RTN","RAHLRU1",77,0) ;Imaging IA (#5023). HLCS, HLSCS, & HLREP defined in INIT^RAHLR "RTN","RAHLRU1",78,0) N I,I1,I2,I3,II "RTN","RAHLRU1",79,0) ;I = HL7 Field # "RTN","RAHLRU1",80,0) ;I1 = Repetition sequence 1,2,3... "RTN","RAHLRU1",81,0) ;I2 = Component "RTN","RAHLRU1",82,0) ;I3 = Subcomponent "RTN","RAHLRU1",83,0) ;HLCS = Component separator "RTN","RAHLRU1",84,0) ;HLSCS = SubComponent separator. "RTN","RAHLRU1",85,0) ;HLREP = Repetition separator "RTN","RAHLRU1",86,0) S I=0 F S I=$O(XX(1,I)) Q:'I S I1=0 K II D "RTN","RAHLRU1",87,0) .F S I1=$O(XX(1,I,I1)) Q:'$L(I1) S I2=0 D S $P(RAD(I+1),HLREP,I1)=$G(II(I1)) "RTN","RAHLRU1",88,0) ..F S I2=$O(XX(1,I,I1,I2)) Q:'$L(I2) S I3=0 D S $P(II(I1),HLCS,I2)=$G(II(I1,I2)) "RTN","RAHLRU1",89,0) ...F S I3=$O(XX(1,I,I1,I2,I3)) Q:'I3 S $P(II(I1,I2),HLSCS,I3)=$G(XX(1,I,I1,I2,I3)) "RTN","RAHLRU1",90,0) S I=0 F S I=$O(RAD(I)) Q:'$L(I) K:'$L(RAD(I)) RAD(I) "RTN","RAHLRU1",91,0) Q "RTN","RAHLRU1",92,0) ; "RTN","RAHLRU1",93,0) RTNSUB(A) ;return the current first level subscript for the A array "RTN","RAHLRU1",94,0) ; default is : HLA array "RTN","RAHLRU1",95,0) ; If array (HLA) is undefined, or only HLA("HLS") defined, return 0 "RTN","RAHLRU1",96,0) S:'$L($G(A)) A="HLA(""HLS""," "RTN","RAHLRU1",97,0) S A=A_"$C(32))" "RTN","RAHLRU1",98,0) Q +$O(@A,-1) "RTN","RAHLRU1",99,0) ; "RTN","RAHLRU1",100,0) BLSEG(SEG,X,ADR) ; "RTN","RAHLRU1",101,0) ;input: SEG="PV1" or "ORC", etc... "RTN","RAHLRU1",102,0) ; X=is the HL7 segment specific array subscripted by field # "RTN","RAHLRU1",103,0) ; Ex: PV1(2) is the PATIENT CLASS "RTN","RAHLRU1",104,0) ; ADR=ADDRESS where to put output if not defined set to HLA("HLS" "RTN","RAHLRU1",105,0) ; but may be: ^TMP("HL7", is the same as root file in Fileman "RTN","RAHLRU1",106,0) N DATA,I,J,JJ,REMAIN,Y,YY,YYSUB,XOLD,SS,A1,A2 "RTN","RAHLRU1",107,0) S:'$L($G(ADR)) ADR="HLA(""HLS""," "RTN","RAHLRU1",108,0) S:ADR'["(" ADR=ADR_"(" "RTN","RAHLRU1",109,0) S A1=ADR_"Y)" ; Y = 1st subscript (ie HLA("HLS",Y)) "RTN","RAHLRU1",110,0) S A2=ADR_"Y,YY)" ;YY = 2nd subscript if split (ie HLA("HLS",Y,YY)) "RTN","RAHLRU1",111,0) ; if YY > 0, it means the segment has been split "RTN","RAHLRU1",112,0) S Y=$$RTNSUB(ADR)+1,YY=0,JJ=0,SS=$E(HLECH,2) "RTN","RAHLRU1",113,0) S @A1=SEG_HLFS,I=0 ;start with SEG, ie, OBR| "RTN","RAHLRU1",114,0) F S I=$O(X(I)) Q:'I D ;loop thru incoming array, ie, RAOBR(n) "RTN","RAHLRU1",115,0) .I $O(X(I,0)) D Q ;two subscripts/repeating field "RTN","RAHLRU1",116,0) ..; This loop is for a second level subscript of the incoming array, "RTN","RAHLRU1",117,0) ..; for example, Assistant Interpreter(s) -> RAOBR(34,1)="FIRST^STAFF", "RTN","RAHLRU1",118,0) ..; RAOBR(34,2)="SECOND^STAFF", RAOBR(34,3)="THIRD^STAFF" etc "RTN","RAHLRU1",119,0) ..S J=0 F S J=$O(X(I,J)) Q:'J D "RTN","RAHLRU1",120,0) ...I YY D Q ;if already split do this loop "RTN","RAHLRU1",121,0) ....S XOLD=$P($G(@A2),HLFS,I-YYSUB),$P(XOLD,SS,J-JJ)=X(I,J) "RTN","RAHLRU1",122,0) ....S $P(@A2,HLFS,I-YYSUB)=XOLD ;add segment to output array "RTN","RAHLRU1",123,0) ....D BLSEG2(.YY,.JJ,1) ;check if over 245, if so, split again "RTN","RAHLRU1",124,0) ...;No split yet "RTN","RAHLRU1",125,0) ...S XOLD=$P($G(@A1),HLFS,I),$P(XOLD,SS,J)=X(I,J) "RTN","RAHLRU1",126,0) ...S $P(@A1,HLFS,I)=XOLD ;add segment to output array "RTN","RAHLRU1",127,0) ...D BLSEG1 ;check if over 245, if so, split for first time "RTN","RAHLRU1",128,0) ..Q "RTN","RAHLRU1",129,0) ..;--------------------------------------------- "RTN","RAHLRU1",130,0) .E D ;single subscript only, non repeating field "RTN","RAHLRU1",131,0) ..S JJ=0 "RTN","RAHLRU1",132,0) ..I YY D Q ;if already split do this loop "RTN","RAHLRU1",133,0) ...S $P(@A2,HLFS,I-YYSUB)=X(I) ;add segment to output array "RTN","RAHLRU1",134,0) ...D BLSEG2(.YY) ;check if over 245, if so, split again "RTN","RAHLRU1",135,0) ...Q "RTN","RAHLRU1",136,0) ..;No split yet "RTN","RAHLRU1",137,0) ..S $P(@A1,HLFS,I)=X(I) ;add segment to output array "RTN","RAHLRU1",138,0) ..D BLSEG1 ;check if over 245, if so, split for first time "RTN","RAHLRU1",139,0) .Q "RTN","RAHLRU1",140,0) Q "RTN","RAHLRU1",141,0) BLSEG1 ;Split for first time "RTN","RAHLRU1",142,0) Q:$L(@A1)<246 ;over 245 chars, split the string first time "RTN","RAHLRU1",143,0) S REMAIN=$E(@A1,246,$L(@A1)) "RTN","RAHLRU1",144,0) S YY=1,@A2=$E(@A1,$L(SEG_HLFS)+1,245) ;YY/subscript = 1 for first split "RTN","RAHLRU1",145,0) S YYSUB=$L(@A2,HLFS) ;YYSUB=number of "|" pieces "RTN","RAHLRU1",146,0) S @A1=SEG_HLFS ;top level is segment only, ie "OBR|" "RTN","RAHLRU1",147,0) S YY=2,@A2=REMAIN,JJ=1 ;YY/subscript = 2 for second half of split "RTN","RAHLRU1",148,0) Q "RTN","RAHLRU1",149,0) BLSEG2(YY,JJ,K) ;Split any subsequent times "RTN","RAHLRU1",150,0) Q:$L(@A2)<246 ;over 245 chars, split the string again... "RTN","RAHLRU1",151,0) S REMAIN=$E(@A2,246,$L(@A2)) "RTN","RAHLRU1",152,0) S @A2=$E(@A2,1,245) "RTN","RAHLRU1",153,0) S YYSUB=YYSUB+$L(@A2,HLFS)-1 ;YYSUB=# of "|" pieces counter "RTN","RAHLRU1",154,0) S YY=YY+1 ;YY/subscript incremented with each split "RTN","RAHLRU1",155,0) S:$G(K) JJ=J-$L(REMAIN,SS) ;K,JJ for repeating field/double subscript "RTN","RAHLRU1",156,0) S @A2=REMAIN "RTN","RAHLRU1",157,0) Q "RTN","RAHLRU1",158,0) PARSEG(ARR,PAR) ;Parse segment from ARR array to PAR array "RTN","RAHLRU1",159,0) Q:'$D(HLFS) "RTN","RAHLRU1",160,0) N SS,I,II,D,FLDN,FLDN1,JJ,D1 S I=0,II=0,J=0,D="",SS=$E($G(HLECH),2) Q:'$L(SS) "RTN","RAHLRU1",161,0) S DATA=$G(ARR(1)) D:$L(DATA) PARPROC(DATA,$O(ARR(1,0))) "RTN","RAHLRU1",162,0) F S I=$O(ARR(1,I)) Q:'I D PARPROC(ARR(1,I),$O(ARR(1,I))) "RTN","RAHLRU1",163,0) Q "RTN","RAHLRU1",164,0) PARPROC(DATA,LAST) ;PROCES DATA "RTN","RAHLRU1",165,0) ;LAST = Indication of last sequence IF LAST = "" (last sequence) "RTN","RAHLRU1",166,0) S FLDN=$L(DATA,HLFS) ;Number of fields "RTN","RAHLRU1",167,0) I FLDN=1 S D=D_DATA Q ;No field separator "RTN","RAHLRU1",168,0) F II=1:1:FLDN D "RTN","RAHLRU1",169,0) .S D=$S(II=1:D,1:"")_$P(DATA,HLFS,II) "RTN","RAHLRU1",170,0) .I II=1,FLDN=1,LAST Q ;ONLY ONE FIELD..no field separators and not last sequence "RTN","RAHLRU1",171,0) .I II=1,FLDN'=1 D GETPP(.D) Q ; First field , more as one field in sequence "RTN","RAHLRU1",172,0) .I II=1,FLDN=1,'LAST D GETPP(.D) Q ; First field, no field delimiters, last sequence "RTN","RAHLRU1",173,0) .I II=FLDN,LAST Q ;Last field, but not last sequence "RTN","RAHLRU1",174,0) .D GETPP(.D) "RTN","RAHLRU1",175,0) S J=J+FLDN-1 "RTN","RAHLRU1",176,0) Q "RTN","RAHLRU1",177,0) GETPP(D) ;GET REPEATED FIELDS "RTN","RAHLRU1",178,0) Q:'$L(D) "RTN","RAHLRU1",179,0) I D'[SS S PAR(J+II)=D K D1 Q "RTN","RAHLRU1",180,0) S FLDN1=$L(D,SS) F JJ=1:1:FLDN1 D "RTN","RAHLRU1",181,0) .S D1=$P(D,SS,JJ) S:$L(D1) PAR(J+II,JJ)=D1 "RTN","RAHLRU1",182,0) Q "RTN","RAHLRU1",183,0) VFIER(X1,X2,X3) ; validation of OBR-32 , OBR-33 or OBR-35 "RTN","RAHLRU1",184,0) ; X1 = value to be Validated/Returned (IEN) "RTN","RAHLRU1",185,0) ; Note: X1 is passed in as: ID Number (IEN)^Family Name^Given Name "RTN","RAHLRU1",186,0) ; (in this example "^" is the subcomponent separator) "RTN","RAHLRU1",187,0) ; X2 = Status ('C'orrected, 'F'inal, or 'R'esults filed, not verified) "RTN","RAHLRU1",188,0) ; X3 = text 'OBR-32' or 'OBR-33' or 'OBR-33x' or 'OBR 35' "RTN","RAHLRU1",189,0) ; Return value: 1 = Validation OK "RTN","RAHLRU1",190,0) ; 0^Error message to be returned to sender "RTN","RAHLRU1",191,0) N C,DIERR,RARRAY,RAERROR,RALBL "RTN","RAHLRU1",192,0) S RALBL=$S(X3="OBR-32":"staff","OBR-33":"resident",1:"transcriptionist") "RTN","RAHLRU1",193,0) ;Note +X1 (we want only the IEN) "RTN","RAHLRU1",194,0) D FIND^DIC(200,"",.01,"A",+X1,"","","","","RARRAY","RAERROR") "RTN","RAHLRU1",195,0) ;if $D(RAERROR("DIERR")) the input value is invalid (control character) "RTN","RAHLRU1",196,0) I $D(RAERROR("DIERR"))#2 Q "0^Invalid "_RALBL_" name" "RTN","RAHLRU1",197,0) ;how many hits? = 0 lookup failed... "RTN","RAHLRU1",198,0) I $P($G(RARRAY("DILIST",0)),U)=0 Q "0^Lookup failed; no "_RALBL_" name found" "RTN","RAHLRU1",199,0) ;how many hits? = 1 just right... "RTN","RAHLRU1",200,0) Q 1 "RTN","RAHLRU1",201,0) ; "RTN","RAHLRU1",202,0) INDT(X1) ;check if MD has inactivation date. "RTN","RAHLRU1",203,0) N RAINDT "RTN","RAHLRU1",204,0) S RAINDT=$$GET1^DIQ(200,+X1,73,"I") I $G(RAINDT),RAINDT'>$$DT^XLFDT S RAERR="Physician is INACTIVE" Q "1^"_RAERR "RTN","RAHLRU1",205,0) Q 0 "RTN","RAHLRU1",206,0) ; "RTN","RAHLRU1",207,0) SR(X1) ;'S'taff or 'R'esident and inactive DATE "RTN","RAHLRU1",208,0) ;input: ID Number (aka IEN) "RTN","RAHLRU1",209,0) ;return: RASTRE: classification (staff, resident, clerk) "RTN","RAHLRU1",210,0) ; : -1 w/error code if error "RTN","RAHLRU1",211,0) I +X1=0 S RASTRE="-1^"_"Missing or invalid IEN" Q "RTN","RAHLRU1",212,0) N DIERR,RARRAY,RAERROR,X,Y S X1=+X1_"," "RTN","RAHLRU1",213,0) D GETS^DIQ(200,X1,"72*:73","I","RARRAY","RAERROR") "RTN","RAHLRU1",214,0) ;if error return error message... "RTN","RAHLRU1",215,0) I $D(RAERROR("DIERR"))#2 S RASTRE="-1^"_"The entry does not exist" Q "RTN","RAHLRU1",216,0) ;we know the function finds a record. "RTN","RAHLRU1",217,0) ;first check: has the individual been inactivated? "RTN","RAHLRU1",218,0) S Y=$G(^RARRAY(200,X1,73,"I")) I Y Q:Y'>DT "-1^user inactivated" "RTN","RAHLRU1",219,0) ;what's the classification of the user? "RTN","RAHLRU1",220,0) S X="",RASTRE=U "RTN","RAHLRU1",221,0) F S X=$O(RARRAY(200.072,X)) Q:X="" S RASTRE=RASTRE_$G(RARRAY(200.072,X,.01,"I"))_U "RTN","RAHLRU1",222,0) Q "RTN","RAHLRU1",223,0) ; "RTN","RAHLRU1",224,0) SPECSRC(RAOIFN) ;Specimen Source OBR-15 "RTN","RAHLRU1",225,0) ;Input: the IEN of the order record from the RAD/NUC MED ORDERS (#75.1) "RTN","RAHLRU1",226,0) ;return: Specimen Source string (PROCEDURE MODIFIERS (left & right only)) "RTN","RAHLRU1",227,0) N RASPSRC S RASS=0 "RTN","RAHLRU1",228,0) F S RASS=$O(^RAO(75.1,RAOIFN,"M",RASS)) Q:'RASS D "RTN","RAHLRU1",229,0) .S RAZPMOD=+$G(^RAO(75.1,RAOIFN,"M",RASS,0)) ;RAZPMOD=ptr to file 71.2 "RTN","RAHLRU1",230,0) .;convert the procedure modifier to lower case "RTN","RAHLRU1",231,0) .S RASPSRC(0)=$$LOW^XLFSTR($P($G(^RAMIS(71.2,RAZPMOD,0)),U)) "RTN","RAHLRU1",232,0) .S:RASPSRC(0)="left"!(RASPSRC(0)="right") RASPSRC=$G(RASPSRC)_RASPSRC(0)_" " "RTN","RAHLRU1",233,0) .Q "RTN","RAHLRU1",234,0) I $L($G(RASPSRC)) S RASPSRC=$E(RASPSRC,1,($L(RASPSRC)-1)) "RTN","RAHLRU1",235,0) K RASS,RAZPMOD "RTN","RAHLRU1",236,0) Q $G(RASPSRC) "RTN","RAHLRU1",237,0) ; "RTN","RAHLRU1",238,0) SETUP ; Setup basic examination information "RTN","RAHLRU1",239,0) S:RASET RACN0=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) "RTN","RAHLRU1",240,0) S RADTE0=9999999.9999-RADTI,RADTECN=$E(RADTE0,4,7)_$E(RADTE0,2,3)_"-"_+RACN0,RARPT0=^RARPT(RARPT,0) "RTN","RAHLRU1",241,0) S RAPROC=+$P(RACN0,U,2),RAPROCIT=+$P($G(^RAMIS(71,RAPROC,0)),U,12),RAPROCIT=$P(^RA(79.2,RAPROCIT,0),U,1) "RTN","RAHLRU1",242,0) S RAPRCNDE=$G(^RAMIS(71,+RAPROC,0)),RACPT=+$P(RAPRCNDE,U,9) "RTN","RAHLRU1",243,0) S RACPTNDE=$$NAMCODE^RACPTMSC(RACPT,DT) "RTN","RAHLRU1",244,0) S Y=$$HLDATE^HLFNC(RADTE0) S RADTE0=$S(Y:Y,1:HLQ),Y=$$M11^HLFNC(RADFN) "RTN","RAHLRU1",245,0) Q "RTN","RAHLRU1",246,0) ; "RTN","RAHLRU1",247,0) USESSAN() ; Return the value of the parameter used as the switch "RTN","RAHLRU1",248,0) ; to turn on use of the Site Specific Accession Numbers "RTN","RAHLRU1",249,0) N RADIVIEN S RADIVIEN="" S RADIVIEN=$O(^RA(79,0)) I RADIVIEN="" Q 0 "RTN","RAHLRU1",250,0) I $P($G(^RA(79,RADIVIEN,.1)),"^",31)="Y" Q 1 "RTN","RAHLRU1",251,0) Q 0 "RTN","RAHLRU1",252,0) ; "RTN","RAHLRU1",253,0) SSANVAL(RADFN,RADTI,RACNI) ; Return the value of the Site Specific Acc Number "RTN","RAHLRU1",254,0) Q $P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",31) "RTN","RAHLRU1",255,0) ; "RTN","RAHLRU1",256,0) DATEPRT(RADTE) ; Return the printable format of the internal date value "RTN","RAHLRU1",257,0) Q $E(RADTE,4,5)_"/"_$E(RADTE,6,7)_"/"_$E(RADTE,2,3) "RTN","RAHLTCPX") 0^17^B93748547 "RTN","RAHLTCPX",1,0) RAHLTCPX ;HIRMFO/RTK,RVD,GJC - Rad/Nuc Med HL7 TCP/IP Bridge;02/11/08 "RTN","RAHLTCPX",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21 "RTN","RAHLTCPX",3,0) ; "RTN","RAHLTCPX",4,0) ; this is a modified copy of RAHLTCPB for HL7 v2.4 "RTN","RAHLTCPX",5,0) ; "RTN","RAHLTCPX",6,0) ;Integration Agreements "RTN","RAHLTCPX",7,0) ;---------------------- "RTN","RAHLTCPX",8,0) ;GENACK^HLMA1(2165); DT^XLFDT(10103) ^DPT("SSN" (10035) "RTN","RAHLTCPX",9,0) ; "RTN","RAHLTCPX",10,0) EN1 ; Main entry point; Build the ^TMP("RARPT-REC" global "RTN","RAHLTCPX",11,0) ; "RTN","RAHLTCPX",12,0) N ARR,HLCS,HLDTM,HLFS,HLSCS,MSA1,PAR,RAI,RAX,RAY,RAXX,RAEXIT,RARCNT "RTN","RAHLTCPX",13,0) N RASEG,RASUB,RAHLTCPB,RANODE,RAVERF,RAESIG,RAERR,RANOSEND "RTN","RAHLTCPX",14,0) N RARRR,RACNPPP,RACKYES,RAPRSET,RAT35,RASTRE,RARE33 "RTN","RAHLTCPX",15,0) D INIT,PROCESS,XIT "RTN","RAHLTCPX",16,0) Q "RTN","RAHLTCPX",17,0) ; "RTN","RAHLTCPX",18,0) INIT ; -- initialize "RTN","RAHLTCPX",19,0) ; "RTN","RAHLTCPX",20,0) S RASUB=HL("MID"),RAHLTCPB=1,RACNPPP=0,RARRR="",RACKYES=0 K RAERR "RTN","RAHLTCPX",21,0) K ^TMP("RARPT-REC",$J,RASUB) ; kill storage area for new HL7 message id "RTN","RAHLTCPX",22,0) S ^TMP("RARPT-REC",$J,RASUB,"RADATE")=$$DT^XLFDT() "RTN","RAHLTCPX",23,0) S ^TMP("RARPT-REC",$J,RASUB,"VENDOR")=$G(HL("SAN")) "RTN","RAHLTCPX",24,0) S:$D(HL("ESIG")) ^TMP("RARPT-REC",$J,RASUB,"RAESIG")=HL("ESIG") ;Save off E-Sig information (if it exists) "RTN","RAHLTCPX",25,0) S:'$$GETSFLAG^RAHLRU($G(HL("SAN")),$G(HL("MTN")),$G(HL("ETN")),$G(HL("VER"))) RANOSEND=$G(HL("SAN")) "RTN","RAHLTCPX",26,0) ; "RTN","RAHLTCPX",27,0) S HLDTM=HL("DTM") "RTN","RAHLTCPX",28,0) S HLFS=HL("FS") "RTN","RAHLTCPX",29,0) S HLCS=$E(HL("ECH")) "RTN","RAHLTCPX",30,0) S HLSCS=$E(HL("ECH"),4) "RTN","RAHLTCPX",31,0) S HLREP=$E(HL("ECH"),2) "RTN","RAHLTCPX",32,0) S HLECH=HL("ECH") "RTN","RAHLTCPX",33,0) Q "RTN","RAHLTCPX",34,0) ; "RTN","RAHLTCPX",35,0) PROCESS ; -- pull message text "RTN","RAHLTCPX",36,0) ; "RTN","RAHLTCPX",37,0) F X HLNEXT Q:HLQUIT'>0!$G(RAEXIT) D "RTN","RAHLTCPX",38,0) .I '$L(HLNODE),$L($G(HLNODE(1))) S HLNODE=HLNODE(1) K HLNODE(1) F J=2:1 Q:'$D(HLNODE(J)) S HLNODE(J-1)=HLNODE(J) K HLNODE(J) "RTN","RAHLTCPX",39,0) .Q:$P(HLNODE,HLFS)="" "RTN","RAHLTCPX",40,0) .Q:"^MSH^PID^PV1^OBR^OBX^ORC^"'[(U_$P(HLNODE,HLFS)_U) "RTN","RAHLTCPX",41,0) .K ARR,PAR M ARR(1)=HLNODE D PARSEG^RAHLRU1(.ARR,.PAR) "RTN","RAHLTCPX",42,0) .D @($P(HLNODE,HLFS)) "RTN","RAHLTCPX",43,0) Q:$G(RAEXIT) "RTN","RAHLTCPX",44,0) I '$D(RASEG("PID")) S RAERR="Missing PID Segment" Q "RTN","RAHLTCPX",45,0) I '$D(RASEG("OBR")) S RAERR="Missing OBR Segment" Q "RTN","RAHLTCPX",46,0) I '$D(RASEG("OBX")) S RAERR="Missing OBX Segment" Q "RTN","RAHLTCPX",47,0) Q "RTN","RAHLTCPX",48,0) ; "RTN","RAHLTCPX",49,0) MSH ; "RTN","RAHLTCPX",50,0) Q "RTN","RAHLTCPX",51,0) PID ; Pick data off the 'PID' segment. "RTN","RAHLTCPX",52,0) ;Req: PID-2(Station number concatenated with dash and DFN ex: 587-1234), "RTN","RAHLTCPX",53,0) ; PID-3(SSN), PID-4(National ICN), PID-5(Patient Name), PID-19(SSN) "RTN","RAHLTCPX",54,0) ;Opt: PID-7(Date of Birth), PID-8(Sex), PID-10(Race), PID-11(Address), "RTN","RAHLTCPX",55,0) ; PID-13(Phone-Home), PID-14(Phone-Bus), PID-22(Ethnic Group) "RTN","RAHLTCPX",56,0) ; "RTN","RAHLTCPX",57,0) ;As a result of PID-2, PID-3, PID-4 discussions/emails with Imaging and "RTN","RAHLTCPX",58,0) ; Identity Management (IDM), the above description is what will be sent "RTN","RAHLTCPX",59,0) ; in fields PID-2 thru PID-4. For parsing incoming ORU messages from "RTN","RAHLTCPX",60,0) ; voice recognition systems, this code will first look for the SSN in "RTN","RAHLTCPX",61,0) ; PID-3. If that is null or not a valid SSN, the code will next look "RTN","RAHLTCPX",62,0) ; for the Station Number-DFN in PID-2. If that is null or does not "RTN","RAHLTCPX",63,0) ; contain a valid DFN, the message will be rejected with an "Invalid "RTN","RAHLTCPX",64,0) ; Patient Identifier" reject message. "RTN","RAHLTCPX",65,0) ; "RTN","RAHLTCPX",66,0) ; get SSN from PID-3/PAR(4) if unsuccessful get DFN from PID-2/PAR(3) "RTN","RAHLTCPX",67,0) S RADFN="" S RASSNVAL=$P($G(PAR(4)),U,1) I RASSNVAL'="" S RADFN=$O(^DPT("SSN",RASSNVAL,"")) "RTN","RAHLTCPX",68,0) I RADFN="" S RADFN=$P($P($G(PAR(3)),U,1),"-",2) ;strip station number and get DFN "RTN","RAHLTCPX",69,0) I $G(RADFN)="" S RAERR="Invalid patient identifier",RAEXIT=1 Q "RTN","RAHLTCPX",70,0) I $G(RADFN)'="" S ^TMP("RARPT-REC",$J,RASUB,"RADFN")=RADFN "RTN","RAHLTCPX",71,0) ; "RTN","RAHLTCPX",72,0) ; get SSN from PID-19/PAR(20) "RTN","RAHLTCPX",73,0) I $G(PAR(20)) S RASSN=PAR(20),^TMP("RARPT-REC",$J,RASUB,"RASSN")=RASSN "RTN","RAHLTCPX",74,0) S RASEG("PID")="" "RTN","RAHLTCPX",75,0) ;.I $P(PAR(5),U,5)="NI" D Q ;check for valid ICN "RTN","RAHLTCPX",76,0) ;..S RAICNVAL=$P($P(PAR(5),U,1),"V",1),RADFN=$$GETDFN^MPIF001(RAICNVAL) "RTN","RAHLTCPX",77,0) ;..I $G(RADFN)<0 S RAERR="Invalid patient ICN",RAEXIT=1,RADFN="" Q "RTN","RAHLTCPX",78,0) Q "RTN","RAHLTCPX",79,0) PV1 ;Ignored at this time. "RTN","RAHLTCPX",80,0) Q "RTN","RAHLTCPX",81,0) ORC ; Pick data off the 'ORC' segment "RTN","RAHLTCPX",82,0) ;Opt: ORC -1 "RTN","RAHLTCPX",83,0) ; = CN The combined result code provides a mechanism to transmit "RTN","RAHLTCPX",84,0) ; results that are associated with two or more orders. "RTN","RAHLTCPX",85,0) ; This situation occurs commonly in reports when the radiologist "RTN","RAHLTCPX",86,0) ; dictates a single report for two or more exams. "RTN","RAHLTCPX",87,0) ; = RE Observations to follow is used to transmit patient-specific information with an order. "RTN","RAHLTCPX",88,0) ; An order detail segment (e.g., OBR) can be followed by one or more observation RASEGments (OBX). "RTN","RAHLTCPX",89,0) ; Any observation that can be transmitted in an ORU message can be transmitted with this mechanism. "RTN","RAHLTCPX",90,0) ; When results are transmitted with an order, the results should immediately follow the order or orders that they support. "RTN","RAHLTCPX",91,0) S RARRR="",RASEG("ORC")=PAR(2) "RTN","RAHLTCPX",92,0) S:PAR(2)="CN" RACNPPP=RACNPPP+1,RARRR="RARPT-REC-"_RACNPPP "RTN","RAHLTCPX",93,0) Q "RTN","RAHLTCPX",94,0) OBR ; Pick data off the 'OBR' segment. "RTN","RAHLTCPX",95,0) ;Req: OBR-1(set ID), OBR-2(Placer Order #), OBR-3(Filler Order #), OBR-4(Uni. Service ID) "RTN","RAHLTCPX",96,0) ; OBR-7(Observ. Date/time), OBR-16(Ord. Provider), OBR-18(Placer Fld 1) "RTN","RAHLTCPX",97,0) ; OBR-19(Placer Fld 2), OBR-20(Filler Fld 1), OBR-21(Filler Fld 2) "RTN","RAHLTCPX",98,0) ; OBR-22(Rslts Rpt/Stat Chng D/T), OBR-25(Rslts Status) "RTN","RAHLTCPX",99,0) ;Opt: OBR-15(Specimen Source), OBR-17(Ord. Callback Phone #), OBR-29(Parent) "RTN","RAHLTCPX",100,0) ; OBR-32(Prin. Rslt Interpreter), OBR-33(Asst. Rslt Interpreter), OBR-35(Transcriptionist) "RTN","RAHLTCPX",101,0) S RASEG("OBR")="" "RTN","RAHLTCPX",102,0) I $L(RARRR) K ^TMP(RARRR,$J) M ^TMP(RARRR,$J)=^TMP("RARPT-REC",$J) ;Merge if OBR without Report "RTN","RAHLTCPX",103,0) S:'$L(RARRR) RARRR="RARPT-REC" "RTN","RAHLTCPX",104,0) N RAX,RAX1,RAX2,RAI,RARR,RAVERF,RARSDNT,RATRANSC,ARR "RTN","RAHLTCPX",105,0) ;OBR-3/PAR(4) for v2.4: site specific accession # (SSS-DDDDDD-CCCCC) "RTN","RAHLTCPX",106,0) ;Note: if SSAN parameter switch is off format is old # (DDDDDD-CCCCC) "RTN","RAHLTCPX",107,0) D:$L(PAR(4)) "RTN","RAHLTCPX",108,0) .S RALONGCN=$P(PAR(4),HLCS),^TMP(RARRR,$J,RASUB,"RALONGCN")=RALONGCN "RTN","RAHLTCPX",109,0) .I RALONGCN="" Q "RTN","RAHLTCPX",110,0) .I $L(RALONGCN,"-")=2 D ;if old format get data from "ADC" x-ref "RTN","RAHLTCPX",111,0) ..S RADTI=$O(^RADPT("ADC",RALONGCN,RADFN,"")) Q:RADTI="" "RTN","RAHLTCPX",112,0) ..S RACNI=$O(^RADPT("ADC",RALONGCN,RADFN,RADTI,"")) Q:RACNI="" "RTN","RAHLTCPX",113,0) .I $L(RALONGCN,"-")=3 D ;if new format get data from "ADC1" x-ref "RTN","RAHLTCPX",114,0) ..S RADTI=$O(^RADPT("ADC1",RALONGCN,RADFN,"")) Q:RADTI="" "RTN","RAHLTCPX",115,0) ..S RACNI=$O(^RADPT("ADC1",RALONGCN,RADFN,RADTI,"")) Q:RACNI="" "RTN","RAHLTCPX",116,0) .Q:RADTI="" "RTN","RAHLTCPX",117,0) .Q:RACNI="" "RTN","RAHLTCPX",118,0) .S ^TMP(RARRR,$J,RASUB,"RADTI")=RADTI "RTN","RAHLTCPX",119,0) .S ^TMP(RARRR,$J,RASUB,"RACNI")=RACNI "RTN","RAHLTCPX",120,0) I $G(RADTI)'>0 S RAERR="Invalid exam registration timestamp" D XIT Q "RTN","RAHLTCPX",121,0) I $G(RACNI)'>0 S RAERR="Invalid exam record IEN" D XIT Q "RTN","RAHLTCPX",122,0) ;OBR-25/PAR(26) STATUS: 'C'orrected, 'F'inal, or 'R'esults filed, not verified "RTN","RAHLTCPX",123,0) I '$L(PAR(26)) S RAERR="Missing Report Status",RAEXIT=1 Q "RTN","RAHLTCPX",124,0) I "CFR"'[PAR(26) S RAERR="Invalid Report Status: "_PAR(26),RAEXIT=1 Q "RTN","RAHLTCPX",125,0) S ^TMP(RARRR,$J,RASUB,"RASTAT")=PAR(26) "RTN","RAHLTCPX",126,0) G:$P(RARRR,"-",3) 112 "RTN","RAHLTCPX",127,0) ;OBR-32 PAR(33) Principal Result Interpreter "RTN","RAHLTCPX",128,0) S RAVERF=+$G(PAR(33)),RAST32=$$VFIER^RAHLRU1(.RAVERF,PAR(26),"OBR-32") I 'RAST32 S RAERR=$P(RAST32,"^",2),RAEXIT=1 Q "RTN","RAHLTCPX",129,0) I '$D(^XUSEC("RA VERIFY",RAVERF)) S RAERR="PHYSICIAN has no RA VERIFY key",RAEXIT=1 Q "RTN","RAHLTCPX",130,0) D SR^RAHLRU1(RAVERF) "RTN","RAHLTCPX",131,0) I +RASTRE=-1 S RAERR=$P(RASTRE,U,2),RAEXIT=1 Q "RTN","RAHLTCPX",132,0) I RASTRE'["^S^" S RAERR="PHYSICIAN must have a STAFF classification" S RAEXIT=1 Q "RTN","RAHLTCPX",133,0) S ^TMP(RARRR,$J,RASUB,"RAVERF")=RAVERF "RTN","RAHLTCPX",134,0) S ^TMP(RARRR,$J,RASUB,"RASTAFF",1)=RAVERF,^("RAWHOCHANGE")=RAVERF ;ID #^family^given "RTN","RAHLTCPX",135,0) ;OBR-33 First Interpreter of Resident type will be the Primary Interpreting staff "RTN","RAHLTCPX",136,0) D:$L($G(PAR(34))) "RTN","RAHLTCPX",137,0) .;build an array of good assistants (active & the proper classification) "RTN","RAHLTCPX",138,0) .S RARR=0 F I=1:1:10 S RARE33=$P(PAR(34),HLREP,I) D:$L(RARE33) "RTN","RAHLTCPX",139,0) ..D SR^RAHLRU1(+RARE33) Q:+RASTRE=-1 "RTN","RAHLTCPX",140,0) ..I RASTRE'["^S^",RASTRE'["^R^" Q ;must be a staff or res. "RTN","RAHLTCPX",141,0) ..;find the first resident... "RTN","RAHLTCPX",142,0) ..I RASTRE["^R^",('($D(RARSDNT)#2)) S (RARSDNT,^TMP(RARRR,$J,RASUB,"RARESIDENT"))=+RARE33 Q "RTN","RAHLTCPX",143,0) ..I RASTRE["^R^" S ^TMP(RARRR,$J,RASUB,"RARESIDENT",I)=+RARE33 Q ; To be stored in 70.03 field 70 "RTN","RAHLTCPX",144,0) ..I RASTRE["^S^" S ^TMP(RARRR,$J,RASUB,"RASTAFF",I)=+RARE33 ;To be stored in 70.03 field 60 "RTN","RAHLTCPX",145,0) ..Q "RTN","RAHLTCPX",146,0) .Q "RTN","RAHLTCPX",147,0) ;"OBR-35" Transcriptionist "RTN","RAHLTCPX",148,0) S RATRANSC=$G(PAR(36)),RATRANSC=$P(RATRANSC,HLCS,4) "RTN","RAHLTCPX",149,0) I RATRANSC'="" S RAT35=$$VFIER^RAHLRU1(.RATRANSC,PAR(26),"OBR-35") I 'RAT35 S RAERR=$P(RAT35,"^",2),RAEXIT=1 Q "RTN","RAHLTCPX",150,0) S ^TMP(RARRR,$J,RASUB,"RATRANSCRIPT")=$S(RATRANSC]"":RATRANSC,$D(RARSDNT):RARSDNT,1:RAVERF) "RTN","RAHLTCPX",151,0) D ESIG^RAHLO3 "RTN","RAHLTCPX",152,0) ;If last OBR set provider info to all OBRs "RTN","RAHLTCPX",153,0) K RAXX F I=1:1:RACNPPP S RAXX=RARRR_"-"_I D:$D(^TMP(RAXX,$J,RASUB)) "RTN","RAHLTCPX",154,0) .N RAXXX M RAXXX=^TMP(RAXX,$J,RASUB),^TMP(RAXX,$J,RASUB)=^TMP(RARRR,$J,RASUB),^TMP(RAXX,$J,RASUB)=RAXXX "RTN","RAHLTCPX",155,0) ; "RTN","RAHLTCPX",156,0) 112 ; "RTN","RAHLTCPX",157,0) I $D(RADTI),$D(RACNI),$D(RAPRSET(RADTI,RACNI)) K RAPRSET(RADTI,RACNI),^TMP(RARRR,$J) S RACNPPP=RACNPPP-1 Q:$P(RARRR,"-",3) M ^TMP(RARRR,$J)=^TMP("RARPT-REC-"_(RACNPPP+1),$J) K ^TMP("RARPT-REC-"_(RACNPPP+1),$J) Q "RTN","RAHLTCPX",158,0) I $D(RADTI),'$D(RAPRSET(RADTI)) D ;Get array of printset for date... "RTN","RAHLTCPX",159,0) .N RAPRTSET,RACN,RASUB,CNT "RTN","RAHLTCPX",160,0) .K RAXX D EN2^RAUTL20(.RAXX) M:$D(RAXX) RAPRSET(RADTI)=RAXX K RAPRSET(RADTI,RACNI) "RTN","RAHLTCPX",161,0) Q "RTN","RAHLTCPX",162,0) ; "RTN","RAHLTCPX",163,0) OBX ; Pick data off the 'OBX' segments "RTN","RAHLTCPX",164,0) ;Req: OBX-2(Value Type), OBX-3(Observ. ID), OBX-5(Observ. Value) "RTN","RAHLTCPX",165,0) ; OBX-11(Observ. Rslt. Status) "RTN","RAHLTCPX",166,0) ; "RTN","RAHLTCPX",167,0) ; OBX-2=CE:Coded Element, T:Text "RTN","RAHLTCPX",168,0) ; OBX-3=Identifier ^ Text ^ Name of Coding System ('^' is the "RTN","RAHLTCPX",169,0) ; component separator) "RTN","RAHLTCPX",170,0) ; P^PROCEDURE^L, I^IMPRESSION^L, D^DIAGNOSTIC CODE^L, M:MODIFIERS^L, "RTN","RAHLTCPX",171,0) ; TCM^TECH COMMENT^L, C4^CPT MODIFIERS^L, R^REPORT^L "RTN","RAHLTCPX",172,0) ; OBX-5=data within classification (OBX-3) by Value Type (OBX-2) "RTN","RAHLTCPX",173,0) ; OBX-11=F:Final Results; C:Correction, replace final results; "RTN","RAHLTCPX",174,0) ; R:Rslts entered-not v'fied "RTN","RAHLTCPX",175,0) ; "RTN","RAHLTCPX",176,0) N RAX S RAOBX3=3 ;RAOBX3 is the # of required components for OBX-3 "RTN","RAHLTCPX",177,0) S RASEG("OBX")="" I $G(PAR(4))']"" S RAERR="Missing Observation Identifier",RAEXIT=1 Q "RTN","RAHLTCPX",178,0) I $L(PAR(4),HLCS)'=RAOBX3 S RAERR="Observation Identifier format error",RAEXIT=1 Q "RTN","RAHLTCPX",179,0) ;verify OBX-3 by component (three components) "RTN","RAHLTCPX",180,0) ;Ex. RAOBR3(1)="P", RAOBR3(2)="PROCEDURE", RAOBR3(3)="L" always "L" "RTN","RAHLTCPX",181,0) F RAI=1:1:RAOBX3 S RAOBX3(RAI)=$P(PAR(4),HLCS,RAI) "RTN","RAHLTCPX",182,0) ; "RTN","RAHLTCPX",183,0) I RAOBX3(3)'="L" S RAERR="Observation Identifier Coding System name in error",RAEXIT=1 Q "RTN","RAHLTCPX",184,0) S RASTR=""_HLCS_"",RASTR(0)=$P(PAR(4),HLCS,1,2) "RTN","RAHLTCPX",185,0) ;RASTR(0)=identifer and text for this specific HL7 message "RTN","RAHLTCPX",186,0) ;build the identifier and text string for all possible values... "RTN","RAHLTCPX",187,0) F RAI=1:1 S RAX=$T(OBX3+RAI) Q:RAX="" S RASTR=RASTR_$P(RAX,";",3)_HLCS_$P(RAX,";",4)_HLCS "RTN","RAHLTCPX",188,0) I RASTR'[(HLCS_RASTR(0)_HLCS) S RAERR="Observation Identifier/Text mismatch" Q "RTN","RAHLTCPX",189,0) ;verify the Observation Value OBX-5 "RTN","RAHLTCPX",190,0) S RAX=$G(PAR(6)),RANODE=$S(RAOBX3(1)="D":"RADX",RAOBX3(1)="I":"RAIMP",1:"RATXT") "RTN","RAHLTCPX",191,0) S RARCNT(RAOBX3(1))=$G(RARCNT(RAOBX3(1)))+1 "RTN","RAHLTCPX",192,0) I RAX["\S\"!(RAX["\R\")!(RAX["\E\")!(RAX["\T\") S RAX=$$DEESC(RAX) "RTN","RAHLTCPX",193,0) ; For DX Codes we are expecting only the # (ie, 1,2,5 etc not the text) "RTN","RAHLTCPX",194,0) ; If VR (PSCRIBE) sends text with DX Code, strip off text in next line "RTN","RAHLTCPX",195,0) ; Text only will be rejected "RTN","RAHLTCPX",196,0) I RAOBX3(1)="D" S RAX=+RAX "RTN","RAHLTCPX",197,0) S ^TMP("RARPT-REC",$J,RASUB,RANODE,RARCNT(RAOBX3(1)))=RAX "RTN","RAHLTCPX",198,0) F RAI=1:1:RACNPPP S RARRR="RARPT-REC-"_RAI S ^TMP(RARRR,$J,RASUB,RANODE,RARCNT(RAOBX3(1)))=RAX "RTN","RAHLTCPX",199,0) K RAOBX3,RASTR "RTN","RAHLTCPX",200,0) Q "RTN","RAHLTCPX",201,0) XIT ; "RTN","RAHLTCPX",202,0) D ERR I RAERRCHK=1 G XIT1 "RTN","RAHLTCPX",203,0) I $D(^TMP("RARPT-REC",$J)) S:'RACNPPP RACKYES=1 D EN1^RAHLO D ERR I RAERRCHK=1 G XIT1 "RTN","RAHLTCPX",204,0) F RAI=1:1:RACNPPP S RARRR="RARPT-REC-"_RAI D:$D(^TMP(RARRR,$J)) "RTN","RAHLTCPX",205,0) .K ^TMP("RARPT-REC",$J) M ^TMP("RARPT-REC",$J)=^TMP(RARRR,$J) K ^TMP(RARRR,$J) "RTN","RAHLTCPX",206,0) .S RACKYES=(RAI=RACNPPP) N I D EN1^RAHLO D ERR I RAERRCHK=1 G XIT1 "RTN","RAHLTCPX",207,0) XIT1 K ^TMP("RARPT-REC",$J) ; kill storage area for current HL7 message id "RTN","RAHLTCPX",208,0) F RAI=1:1:RACNPPP S RARRR="RARPT-REC-"_RAI K ^TMP(RARRR,$J) "RTN","RAHLTCPX",209,0) Q "RTN","RAHLTCPX",210,0) ERR ; "RTN","RAHLTCPX",211,0) S RAERRCHK=0 "RTN","RAHLTCPX",212,0) I $D(RAERR) D "RTN","RAHLTCPX",213,0) .S RAEXIT=1,RACKYES=1,RAERRCHK=1 "RTN","RAHLTCPX",214,0) .D ENX^RAHLEXF(HLDTM,RASUB) "RTN","RAHLTCPX",215,0) .D GENACK "RTN","RAHLTCPX",216,0) .Q "RTN","RAHLTCPX",217,0) Q "RTN","RAHLTCPX",218,0) ; "RTN","RAHLTCPX",219,0) DEESC(RASTR) ;Replace escape sequences with their field separator and escape character "RTN","RAHLTCPX",220,0) ;equivalents. (RAHLTCPX) "RTN","RAHLTCPX",221,0) ; "RTN","RAHLTCPX",222,0) ;input : RASTR=the string of characters being checked for esc sequences "RTN","RAHLTCPX",223,0) ;output: returns a string with field separator and escape characters in "RTN","RAHLTCPX",224,0) ; place of escape sequences "RTN","RAHLTCPX",225,0) ; "RTN","RAHLTCPX",226,0) ;RAFSESC/HLFS = field separator "RTN","RAHLTCPX",227,0) ;RACSESC/$E(HLECH,1) = component separator "RTN","RAHLTCPX",228,0) ;RARSESC/$E(HLECH,2) = repetition separator "RTN","RAHLTCPX",229,0) ;RAESESC/$E(HLECH,3) = escape character "RTN","RAHLTCPX",230,0) ;RASCESC/$E(HLECH,4) = subcomponent separator "RTN","RAHLTCPX",231,0) ; "RTN","RAHLTCPX",232,0) N RAFSESC,RACSESC,RARSESC,RAESESC,RASCESC "RTN","RAHLTCPX",233,0) S RAFSESC="\F\",RACSESC="\S\",RARSESC="\R\",RAESESC="\E\",RASCESC="\T\" "RTN","RAHLTCPX",234,0) N RAYES ;escape characters present? if yes, set YES to one "RTN","RAHLTCPX",235,0) F D Q:'RAYES "RTN","RAHLTCPX",236,0) .S RAYES=0 "RTN","RAHLTCPX",237,0) .I RASTR[RAFSESC S RASTR=$P(RASTR,RAFSESC)_HLFS_$P(RASTR,RAFSESC,2,99999),RAYES=1 "RTN","RAHLTCPX",238,0) .I RASTR[RACSESC S RASTR=$P(RASTR,RACSESC)_$E(HLECH,1)_$P(RASTR,RACSESC,2,99999),RAYES=1 "RTN","RAHLTCPX",239,0) .I RASTR[RARSESC S RASTR=$P(RASTR,RARSESC)_$E(HLECH,2)_$P(RASTR,RARSESC,2,99999),RAYES=1 "RTN","RAHLTCPX",240,0) .I RASTR[RAESESC S RASTR=$P(RASTR,RAESESC)_$E(HLECH,3)_$P(RASTR,RAESESC,2,99999),RAYES=1 "RTN","RAHLTCPX",241,0) .I RASTR[RASCESC S RASTR=$P(RASTR,RASCESC)_$E(HLECH,4)_$P(RASTR,RASCESC,2,99999),RAYES=1 "RTN","RAHLTCPX",242,0) .Q "RTN","RAHLTCPX",243,0) Q RASTR "RTN","RAHLTCPX",244,0) ; "RTN","RAHLTCPX",245,0) GENACK ; Compile the 'ACK' segment, generate the 'ACK' message. "RTN","RAHLTCPX",246,0) Q:'$G(RACKYES) "RTN","RAHLTCPX",247,0) N HLFORMAT,HLARYTYP,RESULT "RTN","RAHLTCPX",248,0) S MSA1="AA" "RTN","RAHLTCPX",249,0) Q:$E($G(HL("SAN")),1,3)'="RA-" ; Don't allow non RA namespaced interfaces "RTN","RAHLTCPX",250,0) I $D(RAERR) S MSA1=$S(HL("SAN")="RA-PSCRIBE-TCP"!$G(RATELE):"AE",1:"AR") "RTN","RAHLTCPX",251,0) ; Added next line to support MedSpeak interface. Must re-initialize "RTN","RAHLTCPX",252,0) ; FS and EC's before sending ACK. "RTN","RAHLTCPX",253,0) ;D:HL("SAN")="RA-CLIENT-TCP" INIT^HLFNC2("RA VOICE TCP SERVER RPT",.HL) "RTN","RAHLTCPX",254,0) S HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$S($D(RAERR):HL("FS")_RAERR,1:"") "RTN","RAHLTCPX",255,0) S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1 "RTN","RAHLTCPX",256,0) K HLRESLT D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.RESULT) "RTN","RAHLTCPX",257,0) I $G(RESULT)="" Q ; RTK 3/26/2008 - UNDEFINED 'RESULT' ERROR "RTN","RAHLTCPX",258,0) I +$P(RESULT,U,2) D ASTATUS^RAHLACK(RESULT,RASUB,HL("SAN")) ;ERROR in gen ACK... "RTN","RAHLTCPX",259,0) Q "RTN","RAHLTCPX",260,0) ; "RTN","RAHLTCPX",261,0) OBX3 ;set the values for OBX-3.1 & OBX-3.2 "RTN","RAHLTCPX",262,0) ;;P;PROCEDURE "RTN","RAHLTCPX",263,0) ;;I;IMPRESSION "RTN","RAHLTCPX",264,0) ;;D;DIAGNOSTIC CODE "RTN","RAHLTCPX",265,0) ;;M;MODIFIERS "RTN","RAHLTCPX",266,0) ;;TCM;TECH COMMENT "RTN","RAHLTCPX",267,0) ;;C4;CPT MODIFIERS "RTN","RAHLTCPX",268,0) ;;R;REPORT "RTN","RAJAC") 0^38^B8745582 "RTN","RAJAC",1,0) RAJAC ;HISC/FPT,GJC AISC/MJK,RMO-Print Film Jacket Labels ;9/5/95 15:26 "RTN","RAJAC",2,0) ;;5.0;Radiology/Nuclear Medicine;**1,8,47**;Mar 16, 1998;Build 21 "RTN","RAJAC",3,0) START I '$D(RATEST) Q:'$D(^RADPT(RADFN,0)) S RAY1=^(0) Q:'$D(^DPT(RADFN,0)) S RAY0=^(0) "RTN","RAJAC",4,0) S RAY2=$G(RASAV2),RAY3=$G(RASAV3) ;from RAREG3 "RTN","RAJAC",5,0) S (RADTI,RACNI)=0 "RTN","RAJAC",6,0) I $D(RAMDIV) S $P(RAY2,"^",3)=RAMDIV "RTN","RAJAC",7,0) I $D(RATEST) D K RAK(0) ;p47 "RTN","RAJAC",8,0) .;w/P47 the LONG CASE NUMBER record in file 78.7 may be required to print "RTN","RAJAC",9,0) .;a legacy LONG CASE NUMBER: 081194-234 or a LONG CASE NUMBER with a site "RTN","RAJAC",10,0) .;prefix: 578-081194-234. RAI is the flag that determines the format to use. "RTN","RAJAC",11,0) .; "RTN","RAJAC",12,0) .F RAK=0:0 S RAK=$O(^RA(78.7,RAK)) Q:RAK'>0 I $D(^(RAK,0)) S RAK(0)=$G(^RA(78.7,RAK,0)) D "RTN","RAJAC",13,0) ..I $P(RAK(0),U)="LONG CASE NUMBER" D LONGCASE^RAFLH2(RAK(0)) Q "RTN","RAJAC",14,0) ..S @$P(RAK(0),U,5)=$P(RAK(0),U,4) "RTN","RAJAC",15,0) ..Q "RTN","RAJAC",16,0) .Q "RTN","RAJAC",17,0) D PRT^RAFLH,CLOSE^RAUTL "RTN","RAJAC",18,0) K RAY0,RAY1,RAY2,RAY3,RADFN,RADTI,RACNI,RATYPE,RAFMT,RANUM,RASAV2,RASAV3 F RAK=0:0 S RAK=$O(^RA(78.7,RAK)) Q:RAK'>0 I $D(^(RAK,0)) K @$P(^(0),"^",5) "RTN","RAJAC",19,0) K RAK Q "RTN","RAJAC",20,0) ; "RTN","RAJAC",21,0) JAC ; Called from LABEL^RAREG3 "RTN","RAJAC",22,0) N RADTI "RTN","RAJAC",23,0) S ION=$P(RAMLC,"^",5),IOP=$S(ION]"":"Q;"_ION,1:"Q") "RTN","RAJAC",24,0) S:IOP="Q" RASELDEV="Select the JACKET LABEL Printer" "RTN","RAJAC",25,0) S RANUM=$S($P(RAMLC,"^",4):$P(RAMLC,"^",4),1:1),RAFMT=$S($P(RAMLC,"^",11):$P(RAMLC,"^",11),1:1) "RTN","RAJAC",26,0) ; "RTN","RAJAC",27,0) ; NOTE: When the location parameter HOW MANY JACKET LABELS PER VISIT "RTN","RAJAC",28,0) ; (File 79.1) equals zero AND the division parameter PRINT JACKET LABELS "RTN","RAJAC",29,0) ; WITH EACH VISIT (File 79) equals YES, the RAPSET routine will set "RTN","RAJAC",30,0) ; $P(RAMLC,U,4) equal to 2 (not zero). "RTN","RAJAC",31,0) ; "RTN","RAJAC",32,0) Q S ZTDTH=$H,ZTRTN="DQ^RAJAC" F RASV=$S($D(RATEST):"RATEST",1:"RADFN"),"RANUM","RAFMT","RAMDIV","RASAV*" S ZTSAVE(RASV)="" "RTN","RAJAC",33,0) S:'$D(RAMES) RAMES="W !?5,""...all film jacket labels queued to print on "",ION,""."",!" "RTN","RAJAC",34,0) W ! D ZIS^RAUTL G KILL:RAPOP "RTN","RAJAC",35,0) ; "RTN","RAJAC",36,0) DQ U IO S U="^" S X="T",%DT="" D ^%DT S DT=Y G START "RTN","RAJAC",37,0) ; "RTN","RAJAC",38,0) DUP D SET^RAPSET1 I $D(XQUIT) K XQUIT D KILL Q "RTN","RAJAC",39,0) S DIC(0)="AEMQ" D ^RADPA G KILL:Y<0 S RADFN=+Y,ION=$P(RAMLC,"^",5),IOP=$S(ION]"":"Q;"_ION,1:"Q") "RTN","RAJAC",40,0) S RAMES="W !!,""Duplicates queued to print on "",ION,"".""",RAFMT=$S($P(RAMLC,"^",11):$P(RAMLC,"^",11),1:1) "RTN","RAJAC",41,0) FLH R !,"How many jacket labels? 1// ",X:DTIME G DUP:'$T!(X["^") S:X="" X=1 S RANUM=X I '(RANUM?.N)!(RANUM>20) W !?3,*7,"Must be a whole number less than 21!" G FLH "RTN","RAJAC",42,0) K RAFL D Q,KILL W ! G DUP "RTN","RAJAC",43,0) ; "RTN","RAJAC",44,0) KILL K %,%W,%X,%Y,A,C,DIC,DUOUT,I,POP,RAFMT,RAMES,RANUM,RADFN,RAPOP,RASV,X,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,POP,DISYS,DFN Q "RTN","RAMAG03C") 0^72^B28078514 "RTN","RAMAG03C",1,0) RAMAG03C ;HCIOFO/SG - ORDERS/EXAMS API (REGISTR. UTILS) ; 2/6/09 11:02am "RTN","RAMAG03C",2,0) ;;5.0;Radiology/Nuclear Medicine;**90,47**;Mar 16, 1998;Build 21 "RTN","RAMAG03C",3,0) ; "RTN","RAMAG03C",4,0) Q "RTN","RAMAG03C",5,0) ; "RTN","RAMAG03C",6,0) ;+++++ CREATES AN EXAM IN THE RAD/NUC MED PATIENT (#70) "RTN","RAMAG03C",7,0) ; "RTN","RAMAG03C",8,0) ; Input variables: "RTN","RAMAG03C",9,0) ; RADFN, RADTE, RADTI, RAEXMVAL, RAIMGTYI, RALOCK, RAMDIV, "RTN","RAMAG03C",10,0) ; RAMISC, RAMLC, RAOIFN, RAPARENT, RAPRLST, RASACN31 "RTN","RAMAG03C",11,0) ; "RTN","RAMAG03C",12,0) ; Output variables: "RTN","RAMAG03C",13,0) ; ^TMP($J,"RAREG1",...), RALOCK "RTN","RAMAG03C",14,0) ; "RTN","RAMAG03C",15,0) ; Return values: "RTN","RAMAG03C",16,0) ; <0 Error descriptor (see $$ERROR^RAERR) "RTN","RAMAG03C",17,0) ; 0 Success "RTN","RAMAG03C",18,0) ; "RTN","RAMAG03C",19,0) ; NOTE: This is an internal entry point. Do not call it from "RTN","RAMAG03C",20,0) ; routines other than the ^RAMAG03. "RTN","RAMAG03C",21,0) ; "RTN","RAMAG03C",22,0) EXAM() ; "RTN","RAMAG03C",23,0) Q:$D(RAPRLST)<10 0 "RTN","RAMAG03C",24,0) N IENS,RACN,RACASE,RACRM,RAFDA,RAIENS,RAIP,RAMOS,RAMSG,RAPROC,RARC,TMP "RTN","RAMAG03C",25,0) K ^TMP($J,"RAREG1") S RARC=0 "RTN","RAMAG03C",26,0) S RAMOS=$S('$G(RAPARENT):"",$G(RAMISC("SINGLERPT")):2,1:1) "RTN","RAMAG03C",27,0) ; "RTN","RAMAG03C",28,0) ;=== Create the date/time record if necessary "RTN","RAMAG03C",29,0) S TMP=$$ROOT^DILFD(70.02,","_RADFN_",",1) "RTN","RAMAG03C",30,0) I '$D(@TMP@(RADTI)) D Q:RARC<0 RARC "RTN","RAMAG03C",31,0) . S IENS="+1,"_RADFN_"," "RTN","RAMAG03C",32,0) . S RAFDA(70.02,IENS,.01)=RADTE ; EXAM DATE "RTN","RAMAG03C",33,0) . S RAFDA(70.02,IENS,2)=RAIMGTYI ; TYPE OF IMAGING "RTN","RAMAG03C",34,0) . S RAFDA(70.02,IENS,3)=RAMDIV ; HOSPITAL DIVISION "RTN","RAMAG03C",35,0) . S RAFDA(70.02,IENS,4)=+RAMLC ; IMAGING LOCATION "RTN","RAMAG03C",36,0) . S:$G(RAPARENT) RAFDA(70.02,IENS,5)=1 ; EXAM SET "RTN","RAMAG03C",37,0) . S RAIENS(1)=RADTI "RTN","RAMAG03C",38,0) . D UPDATE^DIE(,"RAFDA","RAIENS","RAMSG") "RTN","RAMAG03C",39,0) . S:$G(DIERR) RARC=$$DBS^RAERR("RAMSG",-9,70.02,IENS) "RTN","RAMAG03C",40,0) ; "RTN","RAMAG03C",41,0) ;=== Get the credit method from the imaging location "RTN","RAMAG03C",42,0) S RACRM=$$GET1^DIQ(79.1,+RAMLC_",",21,"I",,"RAMSG") "RTN","RAMAG03C",43,0) Q:$G(DIERR) $$DBS^RAERR("RAMSG",-9,79.1,+RAMLC_",") "RTN","RAMAG03C",44,0) ; "RTN","RAMAG03C",45,0) ;=== Register individual case(s) "RTN","RAMAG03C",46,0) S RAIP=0 "RTN","RAMAG03C",47,0) F S RAIP=$O(RAPRLST(RAIP)) Q:RAIP'>0 D Q:RARC<0 "RTN","RAMAG03C",48,0) . S RAPROC=RAPRLST(RAIP) K RAFDA,RAIENS,RAMSG "RTN","RAMAG03C",49,0) . ;--- Generate a case number "RTN","RAMAG03C",50,0) . S RACN=$$CASENUM^RAMAG03D(RADTE) "RTN","RAMAG03C",51,0) . I RACN<0 S RARC=RACN Q "RTN","RAMAG03C",52,0) . ;--- Prepare the data "RTN","RAMAG03C",53,0) . S IENS="+1,"_RADTI_","_RADFN_"," "RTN","RAMAG03C",54,0) . S RAFDA(70.03,IENS,.01)=RACN ; CASE NUMBER "RTN","RAMAG03C",55,0) . S RAFDA(70.03,IENS,2)=+RAPROC ; PROCEDURE "RTN","RAMAG03C",56,0) . S RAFDA(70.03,IENS,4)=RAMISC("EXAMCAT") ; CATEGORY OF EXAM "RTN","RAMAG03C",57,0) . S RAFDA(70.03,IENS,6)=$G(RAMISC("WARD")) ; WARD "RTN","RAMAG03C",58,0) . S RAFDA(70.03,IENS,7)=$G(RAMISC("SERVICE")) ; SERVICE "RTN","RAMAG03C",59,0) . S RAFDA(70.03,IENS,8)=$G(RAMISC("PRINCLIN")) ; PRINCIPAL CLINIC "RTN","RAMAG03C",60,0) . S RAFDA(70.03,IENS,11)=RAOIFN ; IMAGING ORDER "RTN","RAMAG03C",61,0) . S RAFDA(70.03,IENS,19)=$G(RAMISC("BEDSECT")) ; BEDSECTION "RTN","RAMAG03C",62,0) . S RAFDA(70.03,IENS,25)=RAMOS ; MEMBER OF SET "RTN","RAMAG03C",63,0) . S RAFDA(70.03,IENS,26)=RACRM ; CREDIT METHOD "RTN","RAMAG03C",64,0) . ;---Pregnancy Screen and Pregnancy Screen Comment for female pt ages 12-55 "RTN","RAMAG03C",65,0) . I $$PTSEX^RAUTL8(RADFN)="F",(($$PTAGE^RAUTL8(RADFN,"")>11)!($$PTAGE^RAUTL8(RADFN,"")<56)) D "RTN","RAMAG03C",66,0) .. S RAFDA(70.03,IENS,32)="u" "RTN","RAMAG03C",67,0) .. S RAFDA(70.03,IENS,80)="OUTSIDE STUDY" "RTN","RAMAG03C",68,0) . ;--- SITE ACCESSION NUMBER "RTN","RAMAG03C",69,0) . S:$G(RASACN31) RAFDA(70.03,IENS,31)=$$ACCNUM^RAMAGU04(RADTE,RACN) "RTN","RAMAG03C",70,0) . ;--- CLINICAL HISTORY FOR EXAM "RTN","RAMAG03C",71,0) . S TMP=$NA(RAMISC("CLINHIST")) "RTN","RAMAG03C",72,0) . S:$D(@TMP)>1 RAFDA(70.03,IENS,400)=TMP "RTN","RAMAG03C",73,0) . ;--- Values from the order "RTN","RAMAG03C",74,0) . M RAFDA(70.03,IENS)=RAEXMVAL "RTN","RAMAG03C",75,0) . ;--- Add the record "RTN","RAMAG03C",76,0) . D UPDATE^DIE(,"RAFDA","RAIENS","RAMSG") "RTN","RAMAG03C",77,0) . I $G(DIERR) S RARC=$$DBS^RAERR("RAMSG",-9,70.03,IENS) Q "RTN","RAMAG03C",78,0) . S RACASE=RADFN_U_RADTI_U_RAIENS(1) "RTN","RAMAG03C",79,0) . ;--- Add to the list "RTN","RAMAG03C",80,0) . S ^TMP($J,"RAREG1",RAIP)=RACASE_U_RAOIFN "RTN","RAMAG03C",81,0) . ;--- Procedure modifiers "RTN","RAMAG03C",82,0) . S $P(IENS,",")=RAIENS(1) "RTN","RAMAG03C",83,0) . S RARC=$$PROCMOD(IENS,RAPROC) Q:RARC<0 "RTN","RAMAG03C",84,0) . ;---Study Instance UID (70.03; 81) "RTN","RAMAG03C",85,0) . D SIUID($P(IENS,",")) ;where IENS is RACNI,RADTI,RADFN, "RTN","RAMAG03C",86,0) . I $G(DIERR) S RARC=$$DBS^RAERR("RAMSG",-9,70.03,IENS) Q "RTN","RAMAG03C",87,0) . ;--- Exam status "RTN","RAMAG03C",88,0) . S RARC=$$UPDEXMST^RAMAGU05(RACASE,"^^1") Q:RARC<0 "RTN","RAMAG03C",89,0) . ;--- Activity log "RTN","RAMAG03C",90,0) . S TMP=$G(RAMISC("TECHCOMM")) "RTN","RAMAG03C",91,0) . S RARC=$$UPDEXMAL^RAMAGU05(RACASE,"E",TMP) Q:RARC<0 "RTN","RAMAG03C",92,0) ; "RTN","RAMAG03C",93,0) ;=== "RTN","RAMAG03C",94,0) Q $S(RARC<0:RARC,1:0) "RTN","RAMAG03C",95,0) ; "RTN","RAMAG03C",96,0) ;+++++ PERFORMS EXAM POST-PROCESSING "RTN","RAMAG03C",97,0) ; "RTN","RAMAG03C",98,0) ; .RAEXAMS Reference to a local array where identifiers of "RTN","RAMAG03C",99,0) ; registered examination(s) are returned to. "RTN","RAMAG03C",100,0) ; "RTN","RAMAG03C",101,0) ; RADTE Actual date/time of the exam (FileMan) "RTN","RAMAG03C",102,0) ; "RTN","RAMAG03C",103,0) ; Input variables: "RTN","RAMAG03C",104,0) ; RASACN31, ^TMP($J,"RAREG1",...) "RTN","RAMAG03C",105,0) ; "RTN","RAMAG03C",106,0) ; Return values: "RTN","RAMAG03C",107,0) ; <0 Error descriptor (see $$ERROR^RAERR) "RTN","RAMAG03C",108,0) ; '<0 Number of registered examinations "RTN","RAMAG03C",109,0) ; (number of elements in the RAEXAMS array) "RTN","RAMAG03C",110,0) ; "RTN","RAMAG03C",111,0) POSTPROC(RAEXAMS,RADTE) ; "RTN","RAMAG03C",112,0) N IENS,RABUF,RACASE,RACN,RACNI,RADFN,RADTI,RAEXMCNT,RAI,RAMSG,RAOIFN "RTN","RAMAG03C",113,0) S RAEXMCNT=0 K RAEXAMS "RTN","RAMAG03C",114,0) ;=== "RTN","RAMAG03C",115,0) S RAI=0 "RTN","RAMAG03C",116,0) F S RAI=$O(^TMP($J,"RAREG1",RAI)) Q:RAI'>0 D "RTN","RAMAG03C",117,0) . S RACASE=^TMP($J,"RAREG1",RAI) K RABUF,RAMSG "RTN","RAMAG03C",118,0) . S RADFN=$P(RACASE,U),RADTI=$P(RACASE,U,2) "RTN","RAMAG03C",119,0) . S RACNI=$P(RACASE,U,3),RAOIFN=$P(RACASE,U,4) "RTN","RAMAG03C",120,0) . S IENS=$$EXAMIENS^RAMAGU04(RACASE) "RTN","RAMAG03C",121,0) . ;--- Exam identifiers "RTN","RAMAG03C",122,0) . S RACN=$$GET1^DIQ(70.03,IENS,.01,"I",,"RAMSG") "RTN","RAMAG03C",123,0) . S $P(RACASE,U,4)=RACN ; Case number "RTN","RAMAG03C",124,0) . I $G(RASACN31) D ; Accession number "RTN","RAMAG03C",125,0) . . S $P(RACASE,U,5)=$$GET1^DIQ(70.03,IENS,31,"I",,"RAMSG") "RTN","RAMAG03C",126,0) . E S $P(RACASE,U,5)=$$ACCNUM^RAMAGU04(RADTE,RACN,"S") "RTN","RAMAG03C",127,0) . S $P(RACASE,U,6)=RADTE ; Exam date/time "RTN","RAMAG03C",128,0) . S RAEXMCNT=RAEXMCNT+1,RAEXAMS(RAEXMCNT)=RACASE "RTN","RAMAG03C",129,0) . ;--- Execute RA REG* protocols "RTN","RAMAG03C",130,0) . D REG^RAHLRPC "RTN","RAMAG03C",131,0) . ;--- Remove from the list "RTN","RAMAG03C",132,0) . K ^TMP($J,"RAREG1",RAI) "RTN","RAMAG03C",133,0) ;=== "RTN","RAMAG03C",134,0) Q RAEXMCNT "RTN","RAMAG03C",135,0) ; "RTN","RAMAG03C",136,0) ;+++++ STORES PROCEDURE MODIFIERS "RTN","RAMAG03C",137,0) ; "RTN","RAMAG03C",138,0) ; IENS7003 IENS of the exam in the sub-file #70.03 "RTN","RAMAG03C",139,0) ; "RTN","RAMAG03C",140,0) ; RAPROC Radiology procedure and modifiers "RTN","RAMAG03C",141,0) ; ^01: Procedure IEN in file #71 "RTN","RAMAG03C",142,0) ; ^02: Optional procedure modifiers (IENs in "RTN","RAMAG03C",143,0) ; ... the PROCEDURE MODIFIERS file (#71.2)) "RTN","RAMAG03C",144,0) ; ^nn: "RTN","RAMAG03C",145,0) ; "RTN","RAMAG03C",146,0) ; Return values: "RTN","RAMAG03C",147,0) ; <0 Error descriptor (see $$ERROR^RAERR) "RTN","RAMAG03C",148,0) ; 0 Success "RTN","RAMAG03C",149,0) ; "RTN","RAMAG03C",150,0) ; NOTE: This is an internal entry point. Do not call it from "RTN","RAMAG03C",151,0) ; outside of this routine. "RTN","RAMAG03C",152,0) ; "RTN","RAMAG03C",153,0) PROCMOD(IENS7003,RAPROC) ; "RTN","RAMAG03C",154,0) N I,IENS,LP,RAFDA,RAMSG,RAPMCNT,RARC,TMP "RTN","RAMAG03C",155,0) S (RAPMCNT,RARC)=0 "RTN","RAMAG03C",156,0) ;--- Prepare the data "RTN","RAMAG03C",157,0) S LP=$L(RAPROC,U) "RTN","RAMAG03C",158,0) F I=2:1:LP S TMP=$P(RAPROC,U,I) D:TMP'="" "RTN","RAMAG03C",159,0) . S RAPMCNT=RAPMCNT+1,IENS="+"_RAPMCNT_","_IENS7003 "RTN","RAMAG03C",160,0) . S RAFDA(70.1,IENS,.01)="`"_TMP "RTN","RAMAG03C",161,0) ;--- Store procedure modifiers "RTN","RAMAG03C",162,0) D:RAPMCNT>0 "RTN","RAMAG03C",163,0) . D UPDATE^DIE("E","RAFDA",,"RAMSG") "RTN","RAMAG03C",164,0) . S:$G(DIERR) RARC=$$DBS^RAERR("RAMSG",-9,70.1) "RTN","RAMAG03C",165,0) ;--- "RTN","RAMAG03C",166,0) Q RARC "RTN","RAMAG03C",167,0) ; "RTN","RAMAG03C",168,0) SIUID(RACNI) ; "RTN","RAMAG03C",169,0) ;sets field 81 IN 70.03 "RTN","RAMAG03C",170,0) ;IENS, RADFN & RADTI are global "RTN","RAMAG03C",171,0) N RAFDA S RAFDA(70.03,IENS,81)=$$SIUID^RAAPI "RTN","RAMAG03C",172,0) D FILE^DIE("","RAFDA") "RTN","RAMAG03C",173,0) Q "RTN","RANMUSE2") 0^39^B42611600 "RTN","RANMUSE2",1,0) RANMUSE2 ;HISC/SWM-Nuclear Medicine Usage reports ;9/3/97 14:37 "RTN","RANMUSE2",2,0) ;;5.0;Radiology/Nuclear Medicine;**65,47**;Mar 16, 1998;Build 21 "RTN","RANMUSE2",3,0) ; "RTN","RANMUSE2",4,0) ;Supported IA #10061 reference to DEM^VADPT "RTN","RANMUSE2",5,0) ; "RTN","RANMUSE2",6,0) SET ; There are 2 parts: set local arrays and ^tmp() "RTN","RANMUSE2",7,0) ; "RTN","RANMUSE2",8,0) ; part 1 -- raseqd(),raseqi(),ranumd(),ranumi() so to reduce "RTN","RANMUSE2",9,0) ; div and img-typ names to a single number, and so to reduce "RTN","RANMUSE2",10,0) ; the length of the ^tmp() string "RTN","RANMUSE2",11,0) ; raseqd("division name")=sequence number for alpha sort order "RTN","RANMUSE2",12,0) ; raseqi("imaging type name")=sequence number for alpha sort order "RTN","RANMUSE2",13,0) ; ranumd(sequence number for alpha sort order)="division name" "RTN","RANMUSE2",14,0) ; ranumi(sequence number for alpha sort order)="imaging type name" "RTN","RANMUSE2",15,0) ; "RTN","RANMUSE2",16,0) S RA1=0 F S RA1=$O(^RA(79,RA1)) Q:'RA1 S RA2=$P($G(^(RA1,0)),U) S:RA2 RASEQD($P($G(^DIC(4,+RA2,0)),U))="" "RTN","RANMUSE2",17,0) S RA1="",RA2=1 F S RA1=$O(RASEQD(RA1)) Q:RA1="" S RASEQD(RA1)=RA2,RANUMD(RA2)=RA1,RA2=RA2+1 "RTN","RANMUSE2",18,0) ; "RTN","RANMUSE2",19,0) S RA1=0 F S RA1=$O(^RA(79.2,RA1)) Q:'RA1 S RA2=$P($G(^(RA1,0)),U) S:RA2]"" RASEQI(RA2)="" "RTN","RANMUSE2",20,0) S RA1="",RA2=1 F S RA1=$O(RASEQI(RA1)) Q:RA1="" S RASEQI(RA1)=RA2,RANUMI(RA2)=RA1,RA2=RA2+1 "RTN","RANMUSE2",21,0) ; "RTN","RANMUSE2",22,0) ; part 2 -- ^TMP($J,"RA",div,imgtyp,S3,S4,patnam,caseno) "RTN","RANMUSE2",23,0) ; S3 = sort field 3, either radiopharm/whoadmin or examdttm "RTN","RANMUSE2",24,0) ; S4 = sort field 4, either examdttm or radiopharm/whoadmin "RTN","RANMUSE2",25,0) ; "RTN","RANMUSE2",26,0) ; Loop thru ^RADPTN("AB" to select recs within requested date range "RTN","RANMUSE2",27,0) ; "RTN","RANMUSE2",28,0) S RA0=RADTBEG-.0001 "RTN","RANMUSE2",29,0) S1 S RA0=$O(^RADPTN("AB",RA0)) Q:RA0="" Q:RA0>RADTEND S RA1=0 "RTN","RANMUSE2",30,0) S2 S RA1=$O(^RADPTN("AB",RA0,RA1)) G:RA1="" S1 "RTN","RANMUSE2",31,0) S RAN0=$G(^RADPTN(RA1,0)) G:RAN0="" S2 "RTN","RANMUSE2",32,0) S RADFN=$P(RAN0,U) G:RADFN="" S2 "RTN","RANMUSE2",33,0) S RADTI=9999999.9999-$P(RAN0,U,2) G:RADTI="" S2 "RTN","RANMUSE2",34,0) S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",$P(RAN0,U,3),0)) G:RACNI="" S2 "RTN","RANMUSE2",35,0) D EXTRACT "RTN","RANMUSE2",36,0) G S2 "RTN","RANMUSE2",37,0) EXTRACT ; "RTN","RANMUSE2",38,0) S P02=$G(^RADPT(RADFN,"DT",RADTI,0)) Q:P02="" "RTN","RANMUSE2",39,0) S P03=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) Q:P03="" "RTN","RANMUSE2",40,0) S RADIVNAM=$P($G(^DIC(4,+$P(P02,U,3),0)),U) "RTN","RANMUSE2",41,0) Q:'$D(^TMP($J,"RA D-TYPE",RADIVNAM)) ; div not selected "RTN","RANMUSE2",42,0) S RAIMGNAM=$P($G(^RA(79.2,+$P(P02,U,2),0)),U) "RTN","RANMUSE2",43,0) Q:'$D(^TMP($J,"RA I-TYPE",RAIMGNAM)) ; img typ not selected "RTN","RANMUSE2",44,0) S RA2=0 "RTN","RANMUSE2",45,0) F1 S RA2=$O(^RADPTN(RA1,"NUC",RA2)) Q:RA2'=+RA2 "RTN","RANMUSE2",46,0) S RANUC=^RADPTN(RA1,"NUC",RA2,0) "RTN","RANMUSE2",47,0) S RACN=$P(RAN0,U,3) "RTN","RANMUSE2",48,0) S RADIOPH=$$EN1^RAPSAPI(+$P(RANUC,U),.01) ; Radiopharm Name "RTN","RANMUSE2",49,0) I 'RAINPUT,RATITLE["Usage",'$D(^TMP($J,"RA EITHER",RADIOPH)) G F1 ;radioph not selectd "RTN","RANMUSE2",50,0) S RAWHO=$P($G(^VA(200,+$P(RANUC,U,9),0)),U) ; who administered dose "RTN","RANMUSE2",51,0) I RATITLE["Admin",RAWHO="" G F1 ;who admin dose is unknown "RTN","RANMUSE2",52,0) I 'RAINPUT,RATITLE["Admin",'$D(^TMP($J,"RA EITHER",RAWHO)) G F1 ;who not selectd "RTN","RANMUSE2",53,0) S RAXMDTM=$P(RAN0,U,2) ; exam date/time "RTN","RANMUSE2",54,0) S RAPRC0=$G(^RAMIS(71,+$P(P03,U,2),0)) ; procedure 0-node "RTN","RANMUSE2",55,0) S RAPRCNAM=$P(RAPRC0,U) ; procedure name "RTN","RANMUSE2",56,0) S DFN=RADFN D DEM^VADPT "RTN","RANMUSE2",57,0) S RAPATNAM=$P(VADM(1),U) ; patient name "RTN","RANMUSE2",58,0) S RASSN=$P(VADM(2),U,2) ; ssn "RTN","RANMUSE2",59,0) K VADM "RTN","RANMUSE2",60,0) S RADOSE=$P(RANUC,U,7) ; dose administered "RTN","RANMUSE2",61,0) S RADRAWN=$P(RANUC,U,4) ; activity drawn "RTN","RANMUSE2",62,0) I 'RADOSE,'RADRAWN G F1 ; dose admin and drawn both null/zero "RTN","RANMUSE2",63,0) ; ien of procedure sub-record with matching radiopharm "RTN","RANMUSE2",64,0) ; if user changes default radiopharm entry, or "RTN","RANMUSE2",65,0) ; adds a radiopharm that's not defined in file 71 default radiopharm, "RTN","RANMUSE2",66,0) ; the high and low values would be unknown "RTN","RANMUSE2",67,0) S RANUC1=$O(^RAMIS(71,+$P(P03,U,2),"NUC","B",+$P(RANUC,U),0)) "RTN","RANMUSE2",68,0) ; 0-node of procedure sub-record with matching radiopharm "RTN","RANMUSE2",69,0) S:RANUC1 RANUC1=^RAMIS(71,+$P(P03,U,2),"NUC",+RANUC1,0) "RTN","RANMUSE2",70,0) S RAHIGH=$P(RANUC1,U,5) ; high adult dose "RTN","RANMUSE2",71,0) S RALOW=$P(RANUC1,U,6) ; low adult dose "RTN","RANMUSE2",72,0) S RASTERSK="" "RTN","RANMUSE2",73,0) I RADOSE>0,RALOW>0,RADOSE0,RAHIGH>0,RADOSE>RAHIGH S RASTERSK="*" "RTN","RANMUSE2",75,0) D S3S4 "RTN","RANMUSE2",76,0) S ^TMP($J,"RA",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),S3,S4,$E(RAPATNAM,1,15),RACN,RADIOPH)=RASSN_U_RADRAWN_U_RADOSE_U_RAHIGH_U_RALOW_U_RAWHO_U_RASTERSK_U_RAPRCNAM "RTN","RANMUSE2",77,0) I '$D(^TMP($J,"RASUM",$S(RASORT:S3,1:S4),RACN,RASSN)) S ^(RASEQI(RAIMGNAM))=$G(^TMP($J,"RATUNIQ",RASEQD(RADIVNAM),RASEQI(RAIMGNAM)))+1,^(RASEQD(RADIVNAM))=$G(^TMP($J,"RATUNIQ",RASEQD(RADIVNAM)))+1 "RTN","RANMUSE2",78,0) S RAEITHER=$S(RATITLE["Usage":RADIOPH,1:RAWHO) "RTN","RANMUSE2",79,0) I '$D(^TMP($J,"RASUM",$S(RASORT:S3,1:S4),RACN,RASSN,RAEITHER)) S ^(RAEITHER)=$G(^TMP($J,"RATUNIQ",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),RAEITHER))+1,^(RAEITHER)=$G(^TMP($J,"RATUNIQ",RASEQD(RADIVNAM),RAEITHER))+1 "RTN","RANMUSE2",80,0) S ^(RASSN)=$G(^TMP($J,"RASUM",$S(RASORT:S3,1:S4),RACN,RASSN))+1 "RTN","RANMUSE2",81,0) S ^(RAEITHER)=$G(^TMP($J,"RASUM",$S(RASORT:S3,1:S4),RACN,RASSN,RAEITHER))+1 "RTN","RANMUSE2",82,0) ; img typ totals "RTN","RANMUSE2",83,0) S:RASTERSK="*" ^(RAEITHER)=$G(^TMP($J,"RATOUTSD",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),RAEITHER))+1 "RTN","RANMUSE2",84,0) S ^(RAEITHER)=$G(^TMP($J,"RATDRAWN",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),RAEITHER))+RADRAWN "RTN","RANMUSE2",85,0) S ^(RAEITHER)=$G(^TMP($J,"RATDOSE",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),RAEITHER))+RADOSE "RTN","RANMUSE2",86,0) ; "ratradio" is used for either radiopharm or who-admin-dose "RTN","RANMUSE2",87,0) S ^(RAEITHER)=$G(^TMP($J,"RATRADIO",RASEQD(RADIVNAM),RASEQI(RAIMGNAM),RAEITHER))+1 "RTN","RANMUSE2",88,0) ; division totals "RTN","RANMUSE2",89,0) S:RASTERSK="*" ^(RAEITHER)=$G(^TMP($J,"RATOUTSD",RASEQD(RADIVNAM),RAEITHER))+1 "RTN","RANMUSE2",90,0) S ^(RAEITHER)=$G(^TMP($J,"RATDRAWN",RASEQD(RADIVNAM),RAEITHER))+RADRAWN "RTN","RANMUSE2",91,0) S ^(RAEITHER)=$G(^TMP($J,"RATDOSE",RASEQD(RADIVNAM),RAEITHER))+RADOSE "RTN","RANMUSE2",92,0) S ^(RAEITHER)=$G(^TMP($J,"RATRADIO",RASEQD(RADIVNAM),RAEITHER))+1 "RTN","RANMUSE2",93,0) G F1 "RTN","RANMUSE2",94,0) WRT S RASEQD="" "RTN","RANMUSE2",95,0) W1 S RASEQD=$O(^TMP($J,"RA",RASEQD)) Q:RASEQD="" S RASEQI="" "RTN","RANMUSE2",96,0) W2 S RASEQI=$O(^TMP($J,"RA",RASEQD,RASEQI)) G:RASEQI="" W1 S S3="" "RTN","RANMUSE2",97,0) S:RAPG>0 RAXIT=$$EOS^RAUTL5 Q:$G(RAXIT) D PGHD^RANMUSE3,COLHD^RANMUSE3 "RTN","RANMUSE2",98,0) W3 S S3=$O(^TMP($J,"RA",RASEQD,RASEQI,S3)) G:S3="" W2 S S4="" "RTN","RANMUSE2",99,0) W4 S S4=$O(^TMP($J,"RA",RASEQD,RASEQI,S3,S4)) G:S4="" W3 S RAPATNAM="" "RTN","RANMUSE2",100,0) W5 S RAPATNAM=$O(^TMP($J,"RA",RASEQD,RASEQI,S3,S4,RAPATNAM)) G:RAPATNAM="" W4 S RACN="" "RTN","RANMUSE2",101,0) W6 S RACN=$O(^TMP($J,"RA",RASEQD,RASEQI,S3,S4,RAPATNAM,RACN)) G:RACN="" W5 S RADIOPH="" "RTN","RANMUSE2",102,0) W7 S RADIOPH=$O(^TMP($J,"RA",RASEQD,RASEQI,S3,S4,RAPATNAM,RACN,RADIOPH)) G:RADIOPH="" W6 S RA1=^(RADIOPH) "RTN","RANMUSE2",103,0) S RALONGCN=$S(RASORT:S3,1:S4),RALONGCN=$E(RALONGCN,4,7)_$E(RALONGCN,2,3)_"-"_RACN_"@"_$E($P(RALONGCN,".",2)_"000",1,4) "RTN","RANMUSE2",104,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RANMUSE2",105,0) S RACNDSP=$S((RASSAN'=""):RASSAN_"@"_$P(RALONGCN,"@",2),1:RALONGCN) "RTN","RANMUSE2",106,0) S RASSN=$P(RA1,U),RADRAWN=$P(RA1,U,2),RADOSE=$P(RA1,U,3),RAHIGH=$P(RA1,U,4),RALOW=$P(RA1,U,5),RAWHO=$P(RA1,U,6),RASTERSK=$P(RA1,U,7) "RTN","RANMUSE2",107,0) S RAPRCNAM=$P(RA1,U,8) "RTN","RANMUSE2",108,0) I ($Y+4)>IOSL!(RAPG=0) S RAXIT=$$EOS^RAUTL5 Q:RAXIT D PGHD^RANMUSE3,COLHD^RANMUSE3 "RTN","RANMUSE2",109,0) I $$USESSAN^RAHLRU1() W !,RACNDSP,?22,$E(RAPATNAM,1,15),?38,RASSN,?50,$E(RADIOPH,1,14),?56,$J(RADRAWN,10,4),?69,$J(RADOSE,10,4),?79,$J(RALOW,10,4),?89,$J(RAHIGH,10,4),?105,$E(RAPRCNAM,1,15),?121,$E(RAWHO,1,10),?131,RASTERSK "RTN","RANMUSE2",110,0) I '$$USESSAN^RAHLRU1() W !,RALONGCN,?16,$E(RAPATNAM,1,15),?32,RASSN,?44,$E(RADIOPH,1,15),?59,$J(RADRAWN,10,4),?69,$J(RADOSE,10,4),?79,$J(RALOW,10,4),?89,$J(RAHIGH,10,4),?100,$E(RAPRCNAM,1,15),?116,$E(RAWHO,1,15),?131,RASTERSK "RTN","RANMUSE2",111,0) G W7 "RTN","RANMUSE2",112,0) S3S4 ; set subscripts 3 and 4 "RTN","RANMUSE2",113,0) I RATITLE["Usage" D Q "RTN","RANMUSE2",114,0) . I RASORT S S4=$E(RADIOPH,1,15),S3=RAXMDTM "RTN","RANMUSE2",115,0) . I 'RASORT S S3=$E(RADIOPH,1,15),S4=RAXMDTM "RTN","RANMUSE2",116,0) . Q "RTN","RANMUSE2",117,0) I RATITLE["Admin" D Q "RTN","RANMUSE2",118,0) . I RASORT S S4=$E(RAWHO,1,15),S3=RAXMDTM "RTN","RANMUSE2",119,0) . I 'RASORT S S3=$E(RAWHO,1,15),S4=RAXMDTM "RTN","RANMUSE2",120,0) . Q "RTN","RANMUSE2",121,0) Q "RTN","RANMUSE3") 0^40^B17130788 "RTN","RANMUSE3",1,0) RANMUSE3 ;HISC/SWM-Nuclear Medicine Usage reports ;10/20/97 11:09 "RTN","RANMUSE3",2,0) ;;5.0;Radiology/Nuclear Medicine;**65,47**;Mar 16, 1998;Build 21 "RTN","RANMUSE3",3,0) PGHD ; Page Header "RTN","RANMUSE3",4,0) I RAPG!($E(IOST,1,2)="C-") W:$Y>0 @IOF "RTN","RANMUSE3",5,0) S RAPG=RAPG+1 "RTN","RANMUSE3",6,0) W !?35,">>> "_RATITLE_" Report <<<",?90,"Run Date: ",RATDY "RTN","RANMUSE3",7,0) W ?121,"Page: ",RAPG "RTN","RANMUSE3",8,0) W !?50,$S($G(RAHDTYP)="D":"(Division",$G(RAHDTYP)="I":"(Imaging",1:"") W:$G(RAHDTYP)]"" " Summary)" "RTN","RANMUSE3",9,0) W ?85,"For: ",RADTBEG("X")," - ",RADTEND("X") "RTN","RANMUSE3",10,0) W !,"Division: ",RANUMD(RASEQD) W:$G(RAHDTYP)'="D" ?45,"Imaging Type: ",RANUMI(RASEQI) "RTN","RANMUSE3",11,0) Q "RTN","RANMUSE3",12,0) COLHD ; Column Header for detailed report "RTN","RANMUSE3",13,0) I $$USESSAN^RAHLRU1() W !!,"Long-Case@Time",?22,"Patient Name",?38,"SSN",?50,"Radiopharm",?65,"Act.Drawn",?75,"Dose Adm'd",?88,"Low",?98,"High",?105,"Procedure",?121,"Who Adm'd" "RTN","RANMUSE3",14,0) I '$$USESSAN^RAHLRU1() W !!,"Long-Case@Time",?16,"Patient Name",?35,"SSN",?44,"Radiopharm",?59,"Act.Drawn",?69,"Dose Adm'd",?83,"Low",?93,"High",?100,"Procedure",?116,"Who Adm'd" "RTN","RANMUSE3",15,0) W !,RALN "RTN","RANMUSE3",16,0) Q "RTN","RANMUSE3",17,0) COLHDS ; Column Header for summary report "RTN","RANMUSE3",18,0) W !!,$S(RATITLE["Usage":"Radiopharm",1:"Who Admin Dose"),?35,"Total Drawn",?50,"Total Adm'd",?64,"No. cases",?79,"(%)",?90,"No. outside range" "RTN","RANMUSE3",19,0) W !,RALN "RTN","RANMUSE3",20,0) Q "RTN","RANMUSE3",21,0) SUM S RAXIT=$$EOS^RAUTL5 Q:RAXIT "RTN","RANMUSE3",22,0) S RA0=0 "RTN","RANMUSE3",23,0) SM0 S RA0=$O(^TMP($J,"RATUNIQ",RA0)) Q:'RA0 S RA1=0 "RTN","RANMUSE3",24,0) SM2 S RA1=$O(^TMP($J,"RATUNIQ",RA0,RA1)) I RA1'=+RA1 D DIVSUM Q:RAXIT G SM0 "RTN","RANMUSE3",25,0) ; if RA1 is alpha, then node is for division summary "RTN","RANMUSE3",26,0) ; if RA1 is numeric, then node is for imaging summary "RTN","RANMUSE3",27,0) S RASEQD=RA0,RASEQI=RA1 "RTN","RANMUSE3",28,0) S RAHDTYP="I" D PGHD,COLHDS "RTN","RANMUSE3",29,0) SM3 S RA2=$O(^TMP($J,"RATUNIQ",RA0,RA1,RA2)) I RA2="" D FOOTIMG S RAXIT=$$EOS^RAUTL5 Q:RAXIT G SM2 "RTN","RANMUSE3",30,0) W !,$E(RA2,1,30) "RTN","RANMUSE3",31,0) W ?30,$J($G(^TMP($J,"RATDRAWN",RA0,RA1,RA2)),15,4) "RTN","RANMUSE3",32,0) W ?45,$J($G(^TMP($J,"RATDOSE",RA0,RA1,RA2)),15,4) "RTN","RANMUSE3",33,0) W ?64,$J($G(^TMP($J,"RATUNIQ",RA0,RA1,RA2)),7) "RTN","RANMUSE3",34,0) W ?78,$J(100*$S(+$G(^TMP($J,"RATUNIQ",RA0,RA1))=0:0,1:$G(^TMP($J,"RATUNIQ",RA0,RA1,RA2))/^TMP($J,"RATUNIQ",RA0,RA1)),5,2) "RTN","RANMUSE3",35,0) W ?90,$J($G(^TMP($J,"RATOUTSD",RA0,RA1,RA2)),7) "RTN","RANMUSE3",36,0) I ($Y+4)>IOSL!(RAPG=0) S RAXIT=$$EOS^RAUTL5 Q:RAXIT D PGHD,COLHDS "RTN","RANMUSE3",37,0) G SM3 "RTN","RANMUSE3",38,0) DIVSUM ; "RTN","RANMUSE3",39,0) ; skip div summary page if div has only 1 img typ "RTN","RANMUSE3",40,0) Q:$O(^TMP($J,"RATUNIQ",RA0,0))=$O(^TMP($J,"RATUNIQ",RA0,"A"),-1) "RTN","RANMUSE3",41,0) S RAHDTYP="D",RA2="A" "RTN","RANMUSE3",42,0) D PGHD,COLHDS "RTN","RANMUSE3",43,0) DV1 S RA2=$O(^TMP($J,"RATUNIQ",RA0,RA2)) "RTN","RANMUSE3",44,0) I RA2="" D FOOTDIV S RAXIT=$$EOS^RAUTL5 Q "RTN","RANMUSE3",45,0) W !,$E(RA2,1,30) "RTN","RANMUSE3",46,0) W ?30,$J($G(^TMP($J,"RATDRAWN",RA0,RA2)),15,4) "RTN","RANMUSE3",47,0) W ?45,$J($G(^TMP($J,"RATDOSE",RA0,RA2)),15,4) "RTN","RANMUSE3",48,0) W ?64,$J($G(^TMP($J,"RATUNIQ",RA0,RA2)),7) "RTN","RANMUSE3",49,0) W ?78,$J(100*$S(+$G(^TMP($J,"RATUNIQ",RA0))=0:0,1:$G(^TMP($J,"RATUNIQ",RA0,RA2))/^TMP($J,"RATUNIQ",RA0)),5,2) "RTN","RANMUSE3",50,0) W ?90,$J($G(^TMP($J,"RATOUTSD",RA0,RA2)),7) "RTN","RANMUSE3",51,0) I ($Y+4)>IOSL!(RAPG=0) S RAXIT=$$EOS^RAUTL5 Q:RAXIT D PGHD,COLHDS "RTN","RANMUSE3",52,0) G DV1 "RTN","RANMUSE3",53,0) FOOTDIV ; footnotes division "RTN","RANMUSE3",54,0) W !!,RANUMD(RASEQD),"'s Total number of unique cases: ",^TMP($J,"RATUNIQ",RA0) "RTN","RANMUSE3",55,0) D FOOT Q "RTN","RANMUSE3",56,0) FOOTIMG ; footnotes img type "RTN","RANMUSE3",57,0) W !!,RANUMI(RASEQI),"'s Total number of unique cases: ",^TMP($J,"RATUNIQ",RA0,RA1) "RTN","RANMUSE3",58,0) D FOOT Q "RTN","RANMUSE3",59,0) FOOT W !!,"Notes: A case may have more than 1 radiopharm, so total no. unique cases may be less than total no. radiopharms listed." "RTN","RANMUSE3",60,0) W !," * denotes administered dosage outside of normal range." "RTN","RANMUSE3",61,0) Q:RAINPUT "RTN","RANMUSE3",62,0) W !!,$S(RATITLE["Usage":"Radiopharm",1:"Dose administerers")," selected for this report :" W !?6 "RTN","RANMUSE3",63,0) S RA2=0 F S RA2=$O(^TMP($J,"RA EITHER",RA2)) Q:RA2="" W:$X+$L(RA2)>(IOM+2) !?6 W RA2 W:$O(^(RA2))]"" ", " "RTN","RANMUSE3",64,0) Q "RTN","RANMUSE3",65,0) ZERO ; zero out total for imaging type(s) and associated division(s) w/o data "RTN","RANMUSE3",66,0) S RA0="" "RTN","RANMUSE3",67,0) Z1 S RA0=$O(^TMP($J,"RA D-TYPE",RA0)) Q:RA0']"" S RA1="" "RTN","RANMUSE3",68,0) Z2 S RA1=$O(RACCESS(DUZ,"DIV-IMG",RA0,RA1)) G:RA1']"" Z1 "RTN","RANMUSE3",69,0) G:'$D(^TMP($J,"RA I-TYPE",RA1)) Z2 "RTN","RANMUSE3",70,0) S:'$D(^TMP($J,"RATUNIQ",RASEQD(RA0),RASEQI(RA1))) ^TMP($J,"RATUNIQ",RASEQD(RA0),RASEQI(RA1))=0 "RTN","RANMUSE3",71,0) S:'($D(^TMP($J,"RATUNIQ",RASEQD(RA0)))#2) ^TMP($J,"RATUNIQ",RASEQD(RA0))=0 "RTN","RANMUSE3",72,0) G Z2 "RTN","RAORD61") 0^42^B7128704 "RTN","RAORD61",1,0) RAORD61 ;HISC/GJC-Print A Request Cont. ;2/2/98 15:28 "RTN","RAORD61",2,0) ;;5.0;Radiology/Nuclear Medicine;**45,68,47**;Mar 16, 1998;Build 21 "RTN","RAORD61",3,0) ;11/18/05 KAM Remedy Call 100930 Remove extra dash lines "RTN","RAORD61",4,0) ; "RTN","RAORD61",5,0) TC ;technologist information & comment (called from RAORD6) "RTN","RAORD61",6,0) N RA18FL,RA18ARR,RA18EX,RA18CNI,RA18DTI,RA18PRC,RA18ND,RA18TC S RA18EX=0,RA18CNI=0 "RTN","RAORD61",7,0) ;11/18/05 KAM Modified next line - was G:RA18DTI="" DASHLN^RAORD6 "RTN","RAORD61",8,0) S RA18DTI=$O(^RADPT("AO",RAOIFN,RADFN,0)) Q:RA18DTI="" "RTN","RAORD61",9,0) F S RA18CNI=$O(^TMP($J,"RAE2",RADFN,RA18CNI)) Q:+RA18CNI=0 D Q:RAX["^" "RTN","RAORD61",10,0) . S RA18PRC="" "RTN","RAORD61",11,0) . F S RA18PRC=$O(^TMP($J,"RAE2",RADFN,RA18CNI,RA18PRC)) Q:RA18PRC="" D Q:RAX["^" "RTN","RAORD61",12,0) .. ;case info "RTN","RAORD61",13,0) .. I $$USESSAN^RAHLRU1() W !,"Case No: "_$P($G(^RADPT(RADFN,"DT",RA18DTI,"P",RA18CNI,0)),"^",31),! "RTN","RAORD61",14,0) .. I '$$USESSAN^RAHLRU1() W !,"Case No: "_$P($G(^RADPT(RADFN,"DT",RA18DTI,"P",RA18CNI,0)),"^") "RTN","RAORD61",15,0) .. S RA18FL=0,RA18ARR("FT")="" "RTN","RAORD61",16,0) .. S RA18TC=0 F S RA18TC=$O(^RADPT(RADFN,"DT",RA18DTI,"P",RA18CNI,"F",RA18TC)) Q:RA18TC="" S RA18ARR("F")=$G(^RADPT(RADFN,"DT",RA18DTI,"P",RA18CNI,"F",RA18TC,0),0) D Q:$L(RA18ARR("FT"))>32 "RTN","RAORD61",17,0) ... I RA18ARR("F")'=0 S RA18ARR("FT")=RA18ARR("FT")_$P($G(RA18ARR("F")),"^",2)_"-"_$P($G(^RA(78.4,$P($G(RA18ARR("F")),"^",1),0)),"^",1)_";" "RTN","RAORD61",18,0) .. S RA18TC=0 F S RA18TC=$O(^RADPT(RADFN,"DT",RA18DTI,"P",RA18CNI,"TC",RA18TC)) Q:RA18TC="" S RA18ARR("T",RA18TC,0)=$G(^RADPT(RADFN,"DT",RA18DTI,"P",RA18CNI,"TC",RA18TC,0),0) D "RTN","RAORD61",19,0) ... I RA18ARR("T",RA18TC,0)'=0 W:RA18FL>0 ! W ?14,"Tech: " I RA18ARR("T",RA18TC,0)'="" S RA18ARR("N")=$$GET1^DIQ(200,RA18ARR("T",RA18TC,0),.01) W $E($P(RA18ARR("N"),"^",1),1,18) "RTN","RAORD61",20,0) ... W:(RA18FL'>0) ?38," Film: "_$E(RA18ARR("FT"),1,32) "RTN","RAORD61",21,0) ... S RA18FL=RA18FL+1 "RTN","RAORD61",22,0) .. I '$D(RA18ARR("T")) W ?14,"Tech: ",?38," Film: "_$E(RA18ARR("FT"),1,32) "RTN","RAORD61",23,0) .. K RA18ARR("T"),RA18ARR("F"),RA18ARR("N") "RTN","RAORD61",24,0) .. I $O(^TMP($J,"RAE2",RADFN,RA18CNI,RA18PRC,"TCOM",0))>0 D Q "RTN","RAORD61",25,0) ... ;tech comm "RTN","RAORD61",26,0) ... W ! "RTN","RAORD61",27,0) ... S RA18EX=$$TXTOUT^RAUTL11(^TMP($J,"RAE2",RADFN,RA18CNI,RA18PRC,"TCOM",1),1,70,-1,"",4,1,1,1) "RTN","RAORD61",28,0) ... D HD^RAORD6:($Y+6)>IOSL "RTN","RAORD61",29,0) Q "RTN","RAORD61",30,0) ; "RTN","RAPM") 0^68^B73229634 "RTN","RAPM",1,0) RAPM ;HOIFO/TH-Radiology Performance Monitors/Indicator; ;5/12/04 10:03 "RTN","RAPM",2,0) ;;5.0;Radiology/Nuclear Medicine;**37,44,48,67,99,47**;Mar 16, 1998;Build 21 "RTN","RAPM",3,0) ;RVD - 3/19/09 p99. "RTN","RAPM",4,0) ;Supported IA #2056 reference to ^DIQ "RTN","RAPM",5,0) ;Supported IA #10000 reference to C^%DTC "RTN","RAPM",6,0) ;Supported IA #10090 reference to ^DIC(4 "RTN","RAPM",7,0) ; *** Application variables: *** "RTN","RAPM",8,0) ; "RTN","RAPM",9,0) ; Exam Date - RADTE (Regular Fileman format) "RTN","RAPM",10,0) ; RADTI (Inverse Fileman format) "RTN","RAPM",11,0) ; Case Number - RACN Exam Status - RAEXST "RTN","RAPM",12,0) ; Category of Exam - RACAT Primary Interpreting Staff - RAPRIM "RTN","RAPM",13,0) ; Date Report Entered - RARPTDT Verified Date - RAVERDT "RTN","RAPM",14,0) ; Report Status - RARPTST Page Number - RAPG "RTN","RAPM",15,0) ; Type of Report - RARPT "RTN","RAPM",16,0) ; Internal number of an entry in the Patient file (#2) - RADFN "RTN","RAPM",17,0) ; "RTN","RAPM",18,0) INIT ; Check for the existence of RACESS. Pass in user's DUZ! "RTN","RAPM",19,0) I $D(DUZ),($O(RACCESS(DUZ,""))']"") D CHECK^RADLQ3(DUZ) "RTN","RAPM",20,0) ; "RTN","RAPM",21,0) N DIR,DIRUT,RABDATE,RAEDATE,RARPT,DTDIFF,RABEGDT,RAENDDT,RA1 "RTN","RAPM",22,0) N RAM,RARAD,RAR,RAMSG,X,Y K RAP99 "RTN","RAPM",23,0) S (RABDATE,RAEDATE,RAANS,RAANS2,RANODIV,RASINCE,RARAD)="",RAN=0 "RTN","RAPM",24,0) ; RANODIV=1 if one or more exams are missing DIVISION "RTN","RAPM",25,0) PROMPT ; "RTN","RAPM",26,0) W @IOF "RTN","RAPM",27,0) W !!,"Radiology Verification Timeliness Report",!! "RTN","RAPM",28,0) ; Prompt for Report Type. Quit if no report type selected "RTN","RAPM",29,0) D GETRPT K DIR Q:$D(DIRUT) "RTN","RAPM",30,0) ; Prompt for Date Range - Quit if no dates selected "RTN","RAPM",31,0) W !! D GETDATE K DIR Q:$D(DIRUT) "RTN","RAPM",32,0) ; Prompt for Radiologist if Short or Both "RTN","RAPM",33,0) D RADIOL^RAPM3 "RTN","RAPM",34,0) ; Prompt for Division and Imaging Types "RTN","RAPM",35,0) S X=$$DIVLOC^RAUTL7() I X G EXIT "RTN","RAPM",36,0) I $D(^TMP($J,"RA I-TYPE","VASCULAR LAB")) D "RTN","RAPM",37,0) . K ^TMP($J,"RA I-TYPE","VASCULAR LAB") "RTN","RAPM",38,0) . W !!?5,"*** Imaging type 'Vascular Lab' will not be included in this report ***" "RTN","RAPM",39,0) ; Prompt for sort option if Detail "RTN","RAPM",40,0) D:RARPT'="S" SORT K DIR Q:$D(DIRUT) "RTN","RAPM",41,0) ; Prompt for mail delivery if Short or Both "RTN","RAPM",42,0) I RARPT'="D" D EMAIL^RAPM2 K DIR Q:$D(DIRUT) "RTN","RAPM",43,0) ; Warning for Detail or Both "RTN","RAPM",44,0) I RARPT="D"!(RARPT="B") D "RTN","RAPM",45,0) . S RATXT="*** The detail report requires a 132 column output device ***" "RTN","RAPM",46,0) . S RALINE="",$P(RALINE,"*",$L(RATXT))="" "RTN","RAPM",47,0) . W !!?(80-$L(RATXT)\2),RALINE,!?(80-$L(RATXT)\2),RATXT,!?(80-$L(RATXT)\2),RALINE,! "RTN","RAPM",48,0) .Q "RTN","RAPM",49,0) D DEV "RTN","RAPM",50,0) I RAPOP D G EXIT "RTN","RAPM",51,0) . I RAANS!(RAANS2) W !?5,"** No mail will be sent **",$C(7) "RTN","RAPM",52,0) . Q "RTN","RAPM",53,0) START ; Get data and print the report "RTN","RAPM",54,0) S:$D(ZTQUEUED) ZTREQ="@" S RAIO=$S(IO="":0,1:1),RAN=0 "RTN","RAPM",55,0) ;added by patch #99 "RTN","RAPM",56,0) D GETDATA "RTN","RAPM",57,0) I $G(RAP99) S RAS99=1 D PWT^RAPMW(RABDATE,RAEDATE) ;process partial Wait and Time report "RTN","RAPM",58,0) ; "RTN","RAPM",59,0) ;D GETDATA "RTN","RAPM",60,0) I RARPT="S"!(RARPT="B") S RAPG=0 D ^RAPM1 "RTN","RAPM",61,0) I RARPT="D"!(RARPT="B") S RAPG=0 D ^RAPM2 "RTN","RAPM",62,0) I $G(RAP99) K RAS99 S RAL99=1 D PWT^RAPMW(RABDATE,RAEDATE) ;process all wait and time reports "RTN","RAPM",63,0) ; see if need send email "RTN","RAPM",64,0) D SEND^RAPM2 "RTN","RAPM",65,0) D EXIT "RTN","RAPM",66,0) Q "RTN","RAPM",67,0) ; "RTN","RAPM",68,0) GETRPT ; Prompt for Summary or Detail or Both reports; Default = Summary Report "RTN","RAPM",69,0) W !,"Enter Report Type" "RTN","RAPM",70,0) S DIR(0)="S^S:Summary;D:Detail;B:Both" "RTN","RAPM",71,0) S DIR("A")="Select Report Type",DIR("B")="S" "RTN","RAPM",72,0) S DIR("?")="Enter Summary report OR Detail report OR Both reports" "RTN","RAPM",73,0) D ^DIR "RTN","RAPM",74,0) Q:$D(DIRUT) "RTN","RAPM",75,0) S RARPT=Y "RTN","RAPM",76,0) Q "RTN","RAPM",77,0) GETDATE ; Prompt for start and end dates "RTN","RAPM",78,0) S DIR(0)="D^:"_DT_":AEX" "RTN","RAPM",79,0) I RARPT'="D" D "RTN","RAPM",80,0) . W !!?4,"The begin date for Summary and Both must be at least 10 days before today.",! "RTN","RAPM",81,0) . S X1=DT,X2=-10 D C^%DTC S RA1=X "RTN","RAPM",82,0) . S DIR(0)="D^:"_RA1_":AEX" "RTN","RAPM",83,0) . Q "RTN","RAPM",84,0) S DIR("A")="Enter starting date" "RTN","RAPM",85,0) S DIR("?")="Enter date to begin searching from" "RTN","RAPM",86,0) D ^DIR "RTN","RAPM",87,0) Q:$D(DIRUT) "RTN","RAPM",88,0) S RABDATE=Y "RTN","RAPM",89,0) ; "RTN","RAPM",90,0) S RADD=91,X1=RABDATE,X2=RADD D C^%DTC S RAMAXDT=X "RTN","RAPM",91,0) ; put 10 day block for summary report or Both "RTN","RAPM",92,0) I RARPT'="D" D "RTN","RAPM",93,0) . W !!?4,"The ending date for Summary and Both must be at least 10 days before today.",! "RTN","RAPM",94,0) . S X1=DT,X2=-10 D C^%DTC S:XDT RAMAXDT=DT "RTN","RAPM",96,0) S DIR(0)="D^"_RABDATE_":"_RAMAXDT_":AE" "RTN","RAPM",97,0) S DIR("A")="Enter ending date" "RTN","RAPM",98,0) S DIR("?",1)=" +91 days max. for Summary and Detail." "RTN","RAPM",99,0) S DIR("?",2)=" And the ending date for the Summary and Both" "RTN","RAPM",100,0) S DIR("?")=" must be at least 10 days before today." "RTN","RAPM",101,0) D ^DIR "RTN","RAPM",102,0) Q:$D(DIRUT) "RTN","RAPM",103,0) ; "RTN","RAPM",104,0) ; Set end date to end of day "RTN","RAPM",105,0) ; RABDATE and RAEDATE are original values "RTN","RAPM",106,0) ; RABEGDT and RAENDDT are used in GETDATA "RTN","RAPM",107,0) S RAEDATE=Y,RAENDDT=RAEDATE_.9999 "RTN","RAPM",108,0) ; Set start date back to include current day "RTN","RAPM",109,0) S RABEGDT=(RABDATE-1)_.9999 "RTN","RAPM",110,0) Q "RTN","RAPM",111,0) SORT ; Prompt for Sorted by "RTN","RAPM",112,0) W !!,"Sort report by" "RTN","RAPM",113,0) S DIR(0)="S^C:Case Number;E:Category of Exam;I:Imaging Type;P:Patient Name;R:Radiologist;T:Hrs to Transcrip.;V:Hrs to Verif." "RTN","RAPM",114,0) S DIR("A")="Select Sorted by",DIR("B")="C" "RTN","RAPM",115,0) D ^DIR "RTN","RAPM",116,0) Q:$D(DIRUT) "RTN","RAPM",117,0) S RASORT=Y "RTN","RAPM",118,0) S DIR(0)="N^0:240" "RTN","RAPM",119,0) S DIR("A")="Print PENDING and "_$S(RASORT="V":"Verif.",1:"Transrip.")_" hours greater than or equal to" "RTN","RAPM",120,0) S DIR("B")="72" "RTN","RAPM",121,0) S DIR("?")="Enter minimum number of hours elapsed since registration." "RTN","RAPM",122,0) D ^DIR Q:$D(DIRUT) S RASINCE=Y "RTN","RAPM",123,0) Q "RTN","RAPM",124,0) DEV ; Device "RTN","RAPM",125,0) I $D(DIRUT) D EXIT Q "RTN","RAPM",126,0) W:RARPT="B" !!,"Specify device for both summary and detail reports." "RTN","RAPM",127,0) D TASK "RTN","RAPM",128,0) D ZIS^RAUTL "RTN","RAPM",129,0) Q "RTN","RAPM",130,0) TASK ; set vars for taskman "RTN","RAPM",131,0) S ZTRTN="START^RAPM" "RTN","RAPM",132,0) S ZTSAVE("RA*")="" "RTN","RAPM",133,0) S ZTSAVE("^TMP($J,")="" "RTN","RAPM",134,0) ;S ZTSAVE("^TMP($J,""RA D-TYPE"",")="" "RTN","RAPM",135,0) ;S ZTSAVE("^TMP($J,""RA I-TYPE"",")="" "RTN","RAPM",136,0) S:$G(RAP99) ZTDESC="Radiology Timeliness Performance Reports" "RTN","RAPM",137,0) S:'$G(RAP99) ZTDESC="Radiology Verification Timeliness Report" "RTN","RAPM",138,0) Q "RTN","RAPM",139,0) ; "RTN","RAPM",140,0) GETDATA ; Get all the data "RTN","RAPM",141,0) ; Order thru Exam Date (RADTE) "RTN","RAPM",142,0) S RADTE=RABEGDT F S RADTE=$O(^RADPT("AR",RADTE)) Q:'RADTE Q:(RADTE>RAENDDT) D "RTN","RAPM",143,0) . S RADFN="" F S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:'RADFN D "RTN","RAPM",144,0) . . ; Get patient name "RTN","RAPM",145,0) . . S RAPATNM=$$GET1^DIQ(2,RADFN,.01) S:RAPATNM="" RAPATNM=" " "RTN","RAPM",146,0) . . ; Order thru inverse Exam Date (RADTI) "RTN","RAPM",147,0) . . S RADTI="" F S RADTI=$O(^RADPT("AR",RADTE,RADFN,RADTI)) Q:'RADTI D CHECK "RTN","RAPM",148,0) . . Q "RTN","RAPM",149,0) . Q "RTN","RAPM",150,0) Q "RTN","RAPM",151,0) CHECK ; Check type of image "RTN","RAPM",152,0) Q:'$D(^RADPT(RADFN,"DT",RADTI)) ;no exam data at all "RTN","RAPM",153,0) S RAITYP=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2) "RTN","RAPM",154,0) S RAIMGTYP=$P($G(^RA(79.2,+RAITYP,0)),U,1) "RTN","RAPM",155,0) ; quit if img typ is known AND does not match selection "RTN","RAPM",156,0) I RAIMGTYP'="",'$D(^TMP($J,"RA I-TYPE",RAIMGTYP)) Q "RTN","RAPM",157,0) I RAIMGTYP="" S RAIMGTYP="(unknown)" "RTN","RAPM",158,0) ; "RTN","RAPM",159,0) ; Check division - Quit if no division selected "RTN","RAPM",160,0) S RASELDIV=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,3) "RTN","RAPM",161,0) S RACHKDIV=$P($G(^DIC(4,+RASELDIV,0)),U,1) "RTN","RAPM",162,0) ; quit if div is known AND does not match selection "RTN","RAPM",163,0) I RACHKDIV'="",'$D(^TMP($J,"RA D-TYPE",RACHKDIV)) Q "RTN","RAPM",164,0) S:RACHKDIV="" RANODIV=1 "RTN","RAPM",165,0) ; "RTN","RAPM",166,0) ; Get exam related data "RTN","RAPM",167,0) S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI D "RTN","RAPM",168,0) . S (RACN0,RAEXST,RANUM,RACN,RAPRIM,RAPRIMNM,RACAT,RARPTTXT)="" "RTN","RAPM",169,0) . S (RARPTDT,RAVERDT,RARPTST,RADHT,RADHV,RATDFHR,RAVDFHR)="" "RTN","RAPM",170,0) . ; Get 0 node (RACN0) of ^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) "RTN","RAPM",171,0) . S RACN0=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) "RTN","RAPM",172,0) . Q:RACN0="" ; no exam data "RTN","RAPM",173,0) . ; Get Case number: Exam Date - Case Number "RTN","RAPM",174,0) . S RACN=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_$P(RACN0,U,1) "RTN","RAPM",175,0) . N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RAPM",176,0) . S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN) "RTN","RAPM",177,0) . ; Get exam status "RTN","RAPM",178,0) . S RAEXST=$P(RACN0,U,3) "RTN","RAPM",179,0) . Q:RAEXST="" ; no exam status "RTN","RAPM",180,0) . ; Quit if exam's CREDIT METHOD is 2 = no credit "RTN","RAPM",181,0) . Q:$P(RACN0,U,26)=2 "RTN","RAPM",182,0) . ; Quit if exam status is "Cancelled" "RTN","RAPM",183,0) . I $P(^RA(72,RAEXST,0),U,3)=0 Q "RTN","RAPM",184,0) . ; Get number of set - '1' separate; '2' for combined report. "RTN","RAPM",185,0) . S RANUM=$P(RACN0,U,25) "RTN","RAPM",186,0) . ; if member of set > 1 then set RACNI to 99999 to skip remaining cases "RTN","RAPM",187,0) . I RANUM>1 S RACNI=99999 "RTN","RAPM",188,0) . ; Get Radiologist (Primary Interpreting Staff) internal # and name. "RTN","RAPM",189,0) . S RAPRIM=$P(RACN0,U,15) "RTN","RAPM",190,0) . ; if specific radiologist requested, quit if not his/her case "RTN","RAPM",191,0) . I RARAD,RAPRIM'=RARAD Q "RTN","RAPM",192,0) . S RAPRIMNM=$$GET1^DIQ(200,RAPRIM,.01) S:RAPRIMNM="" RAPRIMNM=" " "RTN","RAPM",193,0) . ; Get Category of Exam "RTN","RAPM",194,0) . S RACAT=$P(RACN0,U,4) "RTN","RAPM",195,0) . ; Get Procedure Name "RTN","RAPM",196,0) . S RAPRCN=$P($G(^RAMIS(71,+$P(RACN0,U,2),0)),U) "RTN","RAPM",197,0) . ; Get IEN of imaging report "RTN","RAPM",198,0) . S RARPTTXT=$P(RACN0,U,17) "RTN","RAPM",199,0) . ; Pending if no imaging report OR report doesn't exist in the Report "RTN","RAPM",200,0) . ; file (#74) OR Stub report "RTN","RAPM",201,0) . S RAHASR=0 ;=1 has real report "RTN","RAPM",202,0) . I $D(^RARPT(+RARPTTXT,0)),'$$STUB^RAEDCN1(+RARPTTXT) S RAHASR=1 "RTN","RAPM",203,0) . I 'RAHASR D "RTN","RAPM",204,0) . . S ^TMP($J,"RAPM","TR",0)=$G(^TMP($J,"RAPM","TR",0))+1 "RTN","RAPM",205,0) . . S ^TMP($J,"RAPM","VR",0)=$G(^TMP($J,"RAPM","VR",0))+1 "RTN","RAPM",206,0) . ; Get report info. if real report exists. "RTN","RAPM",207,0) . I RAHASR D RPTINFO^RAPM1 "RTN","RAPM",208,0) . D STORE^RAPM2 "RTN","RAPM",209,0) . ; Calculate the total number of reports "RTN","RAPM",210,0) . S ^TMP($J,"RAPM","TOTAL")=$G(^TMP($J,"RAPM","TOTAL"))+1 "RTN","RAPM",211,0) Q "RTN","RAPM",212,0) EXIT ; Exit "RTN","RAPM",213,0) ; Close device "RTN","RAPM",214,0) D CLOSE^RAUTL "RTN","RAPM",215,0) K RACN0,RAEXST,RANUM,RACN,RAPRIM,RAPRIMNM,RACAT,RARPTTXT,RAANS,RATXT "RTN","RAPM",216,0) K DIR,DIRUT,RABDATE,RAEDATE,RARPT,DTDIFF,RABEGDT,RAENDDT,RAITYP,RAIMGTYP,RATYP "RTN","RAPM",217,0) K ZTRTN,ZTSAVE,ZTDESC,RAPG,RASELDIV,RACHKDIV,RACNO,RAVHRS,RACNDSP,RASSAN "RTN","RAPM",218,0) K RADIV,RAN,RAIMG,RAREC1,RATOTCNT,RACNI,RADFN,RADTE,RADTI,RAHD,RAPATNM "RTN","RAPM",219,0) K RAPOP,RAPSTX,RAQUIT,RAREC,RARPTDT,RARPTST,RASORT,RASRT,RATDFHR,RAHASR "RTN","RAPM",220,0) K RATDFSEC,RATHRS,RAVDFHR,RAVDFSEC,RAVERDT,RAMES,RALINE,RAMAXDT,RADD "RTN","RAPM",221,0) K RAANS2,RAIOM,RAHDR,RANODIV,RASINCE,RADHT,RADHV,RAVAL,RAPRCN "RTN","RAPM",222,0) K RAXIT,RAIO,RALDENT,RALMAX,RALUSED,RATAIL,RAS99,RAL99,RAP99,RAN "RTN","RAPM",223,0) K ^TMP($J) "RTN","RAPM",224,0) Q "RTN","RAPM2") 0^69^B96765436 "RTN","RAPM2",1,0) RAPM2 ;HOIFO/TH-Radiology Performance Monitors/Indicator; ;3/20/04 12:41 "RTN","RAPM2",2,0) ;;5.0;Radiology/Nuclear Medicine;**37,44,48,63,67,99,47**;Mar 16, 1998;Build 21 "RTN","RAPM2",3,0) ; IA 10090 allows Read w/Fileman for entire file 4 "RTN","RAPM2",4,0) ; Supported IA #10103 reference to ^XLFDT "RTN","RAPM2",5,0) ; Supported IA #2056 reference to ^DIQ "RTN","RAPM2",6,0) ; Supported IA #2541 reference to KSP^XUPARAM "RTN","RAPM2",7,0) ; RVD - 3/20/09 p99 "RTN","RAPM2",8,0) ; Print Detail report "RTN","RAPM2",9,0) DETAIL ; Print Detail report "RTN","RAPM2",10,0) I ($Y+5)>IOSL!(RARPT="B") D "RTN","RAPM2",11,0) . I IO=IO(0),($E(IOST,1,2)="C-") D "RTN","RAPM2",12,0) . . R !,"Press RETURN to continue. ",X:DTIME "RTN","RAPM2",13,0) D HDR("D") "RTN","RAPM2",14,0) D PRTTOT "RTN","RAPM2",15,0) D DHDR "RTN","RAPM2",16,0) D DRPT Q:RAXIT "RTN","RAPM2",17,0) D DFOOT "RTN","RAPM2",18,0) Q "RTN","RAPM2",19,0) ; "RTN","RAPM2",20,0) PRTTOT ; Print total number of reports "RTN","RAPM2",21,0) S RATOTCNT=+$G(^TMP($J,"RAPM","TOTAL")) "RTN","RAPM2",22,0) W !,"Total number of reports expected for procedures performed during specified date range: ",$J(RATOTCNT,$L(RATOTCNT)) "RTN","RAPM2",23,0) Q "RTN","RAPM2",24,0) ; "RTN","RAPM2",25,0) DHDR ; Header "RTN","RAPM2",26,0) I ($Y+5)>IOSL D "RTN","RAPM2",27,0) . S RAPG=RAPG+1,RAHD(0)="Detail Verification Timeliness Report" "RTN","RAPM2",28,0) . W @IOF,!?(RAIOM-$L(RAHD(0))\2),RAHD(0),?(RAIOM-10),"Page: ",$G(RAPG) "RTN","RAPM2",29,0) W !!,?34,"Date/Time",?49,"Date/Time",?69,"Date/Time",?102,"Cat" "RTN","RAPM2",30,0) W ?106,"Rpt",?110,"Img",?116,"Procedure" "RTN","RAPM2",31,0) W !,"Patient Name",?17,"Case #",?34,"Registered",?49,"Transcribed",?63,"Hrs" "RTN","RAPM2",32,0) W ?69,"Verified",?83,"Hrs",?88,"Radiologist",?102,"Exm",?106,"Sts" "RTN","RAPM2",33,0) W ?110,"Typ",?119,"Name",! "RTN","RAPM2",34,0) Q "RTN","RAPM2",35,0) ; "RTN","RAPM2",36,0) DRPT ; Read records "RTN","RAPM2",37,0) S RAXIT=0 "RTN","RAPM2",38,0) I '$D(^TMP($J,"RAPM2")) W !!?30,"No data to print...",!!!!! Q "RTN","RAPM2",39,0) S D1="" F S D1=$O(^TMP($J,"RAPM2",D1)) Q:D1="" Q:RAXIT D "RTN","RAPM2",40,0) . S D2="" F S D2=$O(^TMP($J,"RAPM2",D1,D2)) Q:D2="" Q:RAXIT D "RTN","RAPM2",41,0) . . S D3="" F S D3=$O(^TMP($J,"RAPM2",D1,D2,D3)) Q:D3="" Q:RAXIT D "RTN","RAPM2",42,0) . . . D SRT "RTN","RAPM2",43,0) Q "RTN","RAPM2",44,0) ; "RTN","RAPM2",45,0) SRT ; Read records "RTN","RAPM2",46,0) I RASORT="C"!(RASORT="P") S RAREC=$G(^TMP($J,"RAPM2",D1,D2,D3)) D DET Q "RTN","RAPM2",47,0) S D4="" F S D4=$O(^TMP($J,"RAPM2",D1,D2,D3,D4)) Q:D4="" Q:RAXIT D "RTN","RAPM2",48,0) . S RAREC=$G(^TMP($J,"RAPM2",D1,D2,D3,D4)) D DET "RTN","RAPM2",49,0) Q "RTN","RAPM2",50,0) ; "RTN","RAPM2",51,0) DET ; Print detail records "RTN","RAPM2",52,0) ; use Transcription elasped hr for all sorts, except if sort by Verif. "RTN","RAPM2",53,0) S RAVAL=$S(RASORT="V":$P(RAREC,U,13),1:$P(RAREC,U,12)) "RTN","RAPM2",54,0) ; remove symbols before comparison "RTN","RAPM2",55,0) S:$E(RAVAL)="<" RAVAL=.5 S:$E(RAVAL)=">" RAVAL=999 "RTN","RAPM2",56,0) ; include PENDING and those with hours > RASINCE "RTN","RAPM2",57,0) I RAVAL'="",RAVALIOSL D "RTN","RAPM2",59,0) . I IO=IO(0) D "RTN","RAPM2",60,0) . . I $E(IOST,1,2)="C-" R !,"Press RETURN to continue or ""^"" to exit. ",X:DTIME S:X="^" RAXIT=1 "RTN","RAPM2",61,0) . Q:RAXIT "RTN","RAPM2",62,0) . D DHDR "RTN","RAPM2",63,0) Q:RAXIT "RTN","RAPM2",64,0) W !,$E($P(RAREC,U,2),1,14) "RTN","RAPM2",65,0) W ?16,$P(RAREC,U,1) "RTN","RAPM2",66,0) W ?33,$P($$FMTE^XLFDT($P(RAREC,U,3),"2FS"),":",1,2) "RTN","RAPM2",67,0) W ?48,$P($$FMTE^XLFDT($P(RAREC,U,4),"2FS"),":",1,2),?63,$J($P(RAREC,U,12),4) "RTN","RAPM2",68,0) W ?68,$P($$FMTE^XLFDT($P(RAREC,U,5),"2FS"),":",1,2),?82,$J($P(RAREC,U,13),4) "RTN","RAPM2",69,0) I $P(RAREC,U,6)'="" W ?88,$E($P(RAREC,U,6),1,14) "RTN","RAPM2",70,0) W ?104,$P(RAREC,U,7),?107,$P(RAREC,U,8) "RTN","RAPM2",71,0) W ?110,$E($P(RAREC,U,9),1,3),?114,$E($P(RAREC,U,14),1,15) "RTN","RAPM2",72,0) W:$P(RAREC,U,11)="" ?130,"*D" "RTN","RAPM2",73,0) Q "RTN","RAPM2",74,0) ; "RTN","RAPM2",75,0) DFOOT ; Footer for Detail report "RTN","RAPM2",76,0) I ($Y+5)>IOSL D "RTN","RAPM2",77,0) . I IO=IO(0) D "RTN","RAPM2",78,0) . . I $E(IOST,1,2)="C-" R !,"Press RETURN to continue. ",X:DTIME "RTN","RAPM2",79,0) . D DHDR "RTN","RAPM2",80,0) W !!,"Note: Category of Exam: 'I' for Inpatient; 'O' for Outpatient; " "RTN","RAPM2",81,0) W "'C' for Contract; 'S' for Sharing; 'E' for Employee; 'R' for Research" "RTN","RAPM2",82,0) W !," Report Status: 'V' for Verififed; 'R' for Released/Not " "RTN","RAPM2",83,0) W "Verified; 'PD' for Problem Draft; 'D' for Draft" "RTN","RAPM2",84,0) W:RANODIV !," *D = Division is missing" "RTN","RAPM2",85,0) W !!?5,"* A printset, i.e., a set of multiple exams that share the same report, will be expected to have 1 report." "RTN","RAPM2",86,0) W !!?5,"* Cancelled and ""No Credit"" cases are excluded from this report." "RTN","RAPM2",87,0) Q "RTN","RAPM2",88,0) ; "RTN","RAPM2",89,0) STORE ; Store detail information "RTN","RAPM2",90,0) Q:RARPT="S" "RTN","RAPM2",91,0) ; for storage subscript: if no rpt dt, set to neg "RTN","RAPM2",92,0) S RADHT=$S(RARPTDT="":-1,1:RATDFHR) "RTN","RAPM2",93,0) S RADHV=$S(RAVERDT="":-1,1:RAVDFHR) "RTN","RAPM2",94,0) ; for display: truncate decimal portion of hours "RTN","RAPM2",95,0) S:RATDFHR'="" RATDFHR=RATDFHR\1 "RTN","RAPM2",96,0) S:RAVDFHR'="" RAVDFHR=RAVDFHR\1 "RTN","RAPM2",97,0) S RATDFHR=$S(RATDFHR="":"",RATDFHR<1:"<1",RATDFHR>999:">999",1:RATDFHR) "RTN","RAPM2",98,0) S RAVDFHR=$S(RAVDFHR="":"",RAVDFHR<1:"<1",RAVDFHR>999:">999",1:RAVDFHR) "RTN","RAPM2",99,0) ; "RTN","RAPM2",100,0) I $$USESSAN^RAHLRU1() S RAREC1=RACNDSP_U_RAPATNM_U_RADTE_U_RARPTDT_U "RTN","RAPM2",101,0) I '$$USESSAN^RAHLRU1() S RAREC1=RACN_U_RAPATNM_U_RADTE_U_RARPTDT_U "RTN","RAPM2",102,0) S RAREC1=RAREC1_RAVERDT_U_RAPRIMNM_U_RACAT_U_RARPTST_U_RAIMGTYP_U "RTN","RAPM2",103,0) S RAREC1=RAREC1_RADFN_U_RACHKDIV_U_RATDFHR_U_RAVDFHR_U_RAPRCN "RTN","RAPM2",104,0) ; "RTN","RAPM2",105,0) I RASORT="C" S ^TMP($J,"RAPM2",$P(RADTE,"."),RACN,RAPATNM)=RAREC1 "RTN","RAPM2",106,0) I RASORT="P" S ^TMP($J,"RAPM2",RAPATNM,$P(RADTE,"."),RACN)=RAREC1 "RTN","RAPM2",107,0) I RASORT="I" S ^TMP($J,"RAPM2",RAIMGTYP,$P(RADTE,"."),RACN,RAPATNM)=RAREC1 "RTN","RAPM2",108,0) I RASORT="E" S ^TMP($J,"RAPM2",RACAT,$P(RADTE,"."),RACN,RAPATNM)=RAREC1 "RTN","RAPM2",109,0) I RASORT="R" S ^TMP($J,"RAPM2",RAPRIMNM,$P(RADTE,"."),RACN,RAPATNM)=RAREC1 "RTN","RAPM2",110,0) I RASORT="T" S ^TMP($J,"RAPM2",RADHT,RADTE,RACN,RAPATNM)=RAREC1 "RTN","RAPM2",111,0) I RASORT="V" S ^TMP($J,"RAPM2",RADHV,RADTE,RACN,RAPATNM)=RAREC1 "RTN","RAPM2",112,0) Q "RTN","RAPM2",113,0) EMAIL ; Ask if ready to email the summary report "RTN","RAPM2",114,0) N RA1 "RTN","RAPM2",115,0) W ! S DIR(0)="Y" "RTN","RAPM2",116,0) S DIR("A")="Send summary report to local mail group ""G.RAD PERFORMANCE INDICATOR""" "RTN","RAPM2",117,0) S DIR("B")="Yes" "RTN","RAPM2",118,0) D ^DIR "RTN","RAPM2",119,0) Q:$D(DIRUT) "RTN","RAPM2",120,0) S RAANS=Y "RTN","RAPM2",121,0) S RA1=$O(^RA(79,0)) Q:'RA1 "RTN","RAPM2",122,0) I '$O(^RA(79,RA1,1,0)) D Q "RTN","RAPM2",123,0) . W !!,?5,"No OUTLOOK mail group(s) have been entered yet." "RTN","RAPM2",124,0) . Q "RTN","RAPM2",125,0) W ! S DIR(0)="Y" "RTN","RAPM2",126,0) S DIR("A")="Send summary report to OUTLOOK mail group(s)" "RTN","RAPM2",127,0) S DIR("B")="Yes" "RTN","RAPM2",128,0) D ^DIR "RTN","RAPM2",129,0) S RAANS2=Y "RTN","RAPM2",130,0) I RAANS2 D CKMONTH^RAPM4 "RTN","RAPM2",131,0) Q "RTN","RAPM2",132,0) SEND ; Send summary report to mail group "RTN","RAPM2",133,0) I RAANS=0,RAANS2=0 Q "RTN","RAPM2",134,0) N RA1,RA2,RASVSUB,RASVTEXT,RASTR "RTN","RAPM2",135,0) S:$G(RAP99) XMSUB="Radiology Timeliness Performance Reports" "RTN","RAPM2",136,0) S:'$G(RAP99) XMSUB="Radiology Summary Verification Timeliness" "RTN","RAPM2",137,0) S XMDUZ=DUZ "RTN","RAPM2",138,0) S XMTEXT="^TMP($J,""RAPM""," "RTN","RAPM2",139,0) S RASVSUB=XMSUB,RASVTEXT=XMTEXT "RTN","RAPM2",140,0) I RAANS=1 D "RTN","RAPM2",141,0) . S XMY("G.RAD PERFORMANCE INDICATOR")="" "RTN","RAPM2",142,0) . D ^XMD "RTN","RAPM2",143,0) . K XMY "RTN","RAPM2",144,0) . Q "RTN","RAPM2",145,0) I RAANS2=1 D "RTN","RAPM2",146,0) . S RA1=$O(^RA(79,0)) Q:'RA1 "RTN","RAPM2",147,0) . S XMSUB=RASVSUB,XMTEXT=RASVTEXT "RTN","RAPM2",148,0) . S RA2=0 "RTN","RAPM2",149,0) .; Outlook mailgroup flagged for HQ should always get automatic mid- "RTN","RAPM2",150,0) .; mid-month rpt, but only get user-initiated rpt if user specifies so "RTN","RAPM2",151,0) .; "RTN","RAPM2",152,0) .; All non-HQ outlook mailgroups get all reports, including autom rpt "RTN","RAPM2",153,0) .; "RTN","RAPM2",154,0) . F S RA2=$O(^RA(79,RA1,1,RA2)) Q:'RA2 S RASTR=$G(^(RA2,0)) D "RTN","RAPM2",155,0) .. I $P(RASTR,U,2)="Y",$G(RAUTOM) S XMY($P(RASTR,U))="" "RTN","RAPM2",156,0) .. I $P(RASTR,U,2)'="Y" S XMY($P(RASTR,U))="" "RTN","RAPM2",157,0) .. Q "RTN","RAPM2",158,0) . Q:'$D(XMY) "RTN","RAPM2",159,0) . D ^XMD "RTN","RAPM2",160,0) . K XMY "RTN","RAPM2",161,0) . Q "RTN","RAPM2",162,0) K XMDUZ "RTN","RAPM2",163,0) Q "RTN","RAPM2",164,0) HDR(RATYP) ; Print appropriate header and process wait and time "RTN","RAPM2",165,0) U:RAIO IO S RAPG=$G(RAPG)+1 "RTN","RAPM2",166,0) I RAPG>1!($E(IOST,1,2)="C-") W:RAIO @IOF "RTN","RAPM2",167,0) I $E(IOST,1,2)="P-",(RAPG>1) W:RAIO @IOF "RTN","RAPM2",168,0) S RAHD(0)=$S(RATYP="S":"Summary",RATYP="D":"Detail",1:"") "RTN","RAPM2",169,0) S RAHD(0)=RAHD(0)_" Verification Timeliness Report" "RTN","RAPM2",170,0) S RAIOM=$S(RATYP="S":80,1:IOM) "RTN","RAPM2",171,0) W:RAIO !?(RAIOM-$L(RAHD(0))\2),RAHD(0),?(RAIOM-10),"Page: ",$G(RAPG),! "RTN","RAPM2",172,0) I RATYP="S" S RAN=RAN+1 D "RTN","RAPM2",173,0) . S ^TMP($J,"RAPM",RAN)=" Summary Verification Timeliness Report Page: "_$G(RAPG) S RAN=RAN+1 "RTN","RAPM2",174,0) . S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1 "RTN","RAPM2",175,0) ; "RTN","RAPM2",176,0) S:'$G(DUZ(2)) DUZ(2)=$$KSP^XUPARAM("INST") ;added by p99 "RTN","RAPM2",177,0) D GETS^DIQ(4,DUZ(2),".01;14*;99","E","RAR","RAMSG") "RTN","RAPM2",178,0) K X "RTN","RAPM2",179,0) S X(1)=RAR(4,DUZ(2)_",",.01,"E") ; Name of facility "RTN","RAPM2",180,0) S X(2)=RAR(4,DUZ(2)_",",99,"E") ; Station Number "RTN","RAPM2",181,0) I $D(RAR(4.014)) D "RTN","RAPM2",182,0) . S X(3)=RAR(4.014,"1,"_DUZ(2)_",",.01,"E") ; Association "RTN","RAPM2",183,0) . S X(4)=RAR(4.014,"1,"_DUZ(2)_",",1,"E") ; Parent of Association "RTN","RAPM2",184,0) . S X(5)=$S(X(3)="VISN":X(4),1:"") ; should be VISN number "RTN","RAPM2",185,0) E S X(5)="" "RTN","RAPM2",186,0) ; "RTN","RAPM2",187,0) W:RAIO !,"Facility: ",X(1),?41,"Station: ",X(2),?60,"VISN: ",X(5) "RTN","RAPM2",188,0) I RATYP="S" D "RTN","RAPM2",189,0) . S $P(X(6)," ",79)="" "RTN","RAPM2",190,0) . S $E(X(6),1,(10+$L(X(1))))="Facility: "_X(1) "RTN","RAPM2",191,0) . S $E(X(6),41,(50+$L(X(2))))="Station: "_X(2) "RTN","RAPM2",192,0) . S $E(X(6),60,(66+$L(X(5))))="VISN: "_X(5) "RTN","RAPM2",193,0) . S ^TMP($J,"RAPM",RAN)=X(6) "RTN","RAPM2",194,0) . S RAN=RAN+1 "RTN","RAPM2",195,0) . Q "RTN","RAPM2",196,0) W !,"Division: " "RTN","RAPM2",197,0) I RATYP="S" S ^TMP($J,"RAPM",RAN)="Division: " "RTN","RAPM2",198,0) D DIV "RTN","RAPM2",199,0) S:(RATYP="S") RAN=RAN+1 "RTN","RAPM2",200,0) ; "RTN","RAPM2",201,0) W:RAIO !,"Exam Date Range: " "RTN","RAPM2",202,0) W:RAIO $$FMTE^XLFDT(RABDATE,"2D")," - ",$$FMTE^XLFDT(RAEDATE,"2D") "RTN","RAPM2",203,0) I RATYP="S" D "RTN","RAPM2",204,0) .S:'$G(RAP99) ^TMP($J,"RAPM",RAN)="" "RTN","RAPM2",205,0) .S RAN=RAN+1,^TMP($J,"RAPM",RAN)="Exam Date Range: "_$$FMTE^XLFDT(RABDATE,"2D")_" - "_$$FMTE^XLFDT(RAEDATE,"2D")_" " S RAN=RAN+1 "RTN","RAPM2",206,0) ; "RTN","RAPM2",207,0) W:RAIO !,"Imaging Type(s): " "RTN","RAPM2",208,0) I RATYP="S",'$G(RAP99) S RAN=RAN+1,^TMP($J,"RAPM",RAN)="",RAN=RAN+1,^TMP($J,"RAPM",RAN)="Imaging Type(s): " "RTN","RAPM2",209,0) D IMG "RTN","RAPM2",210,0) S:RATYP="S" RAN=RAN+1 "RTN","RAPM2",211,0) ; "RTN","RAPM2",212,0) ; Run date and time "RTN","RAPM2",213,0) S NOW=$$NOW^XLFDT,NOW=$P(NOW,".",1)_"."_$E($P(NOW,".",2),1,4) "RTN","RAPM2",214,0) W:RAIO !,"Run Date/Time: ",$$FMTE^XLFDT(NOW,"2P"),! "RTN","RAPM2",215,0) I RATYP="S" S RAN=RAN+1,^TMP($J,"RAPM",RAN)="Run Date/Time: "_$$FMTE^XLFDT(NOW,"2P"),RAN=RAN+1 "RTN","RAPM2",216,0) I RARAD D "RTN","RAPM2",217,0) . W:RAIO !,"Primary Interpreting Staff Physician: ",$$GET1^DIQ(200,RARAD,.01),! "RTN","RAPM2",218,0) . I RATYP="S" D "RTN","RAPM2",219,0) .. S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1 "RTN","RAPM2",220,0) .. S ^TMP($J,"RAPM",RAN)="Primary Interpreting Staff Physician: "_$$GET1^DIQ(200,RARAD,.01),RAN=RAN+1 "RTN","RAPM2",221,0) .. Q "RTN","RAPM2",222,0) . Q "RTN","RAPM2",223,0) I (RARPT="D"!(RARPT="B")),(RATYP'="S") D "RTN","RAPM2",224,0) . S RASRT=$S(RASORT="C":"Case Number",RASORT="E":"Category of Exam",RASORT="I":"Imaging Type",RASORT="P":"Patient Name",RASORT="R":"Radiologist",RASORT="T":"Hrs to Transcription",RASORT="V":"Hrs to Verification",1:"") "RTN","RAPM2",225,0) . W:RAIO !,"Sorted by: ",RASRT,?45,"Min. hours elasped to "_$S(RASORT="V":"Verification",1:"Transcription")_": "_RASINCE "RTN","RAPM2",226,0) Q "RTN","RAPM2",227,0) DIV ; List selected Division "RTN","RAPM2",228,0) Q:'$D(^TMP($J,"RA D-TYPE")) "RTN","RAPM2",229,0) S RADIV="" F I=1:1 S RADIV=$O(^TMP($J,"RA D-TYPE",RADIV)) Q:RADIV="" D "RTN","RAPM2",230,0) . I $X'>(RAIOM-$L("Division(s): ")) D "RTN","RAPM2",231,0) . . W:RAIO RADIV_$S($O(^TMP($J,"RA D-TYPE",RADIV))]"":", ",1:"") "RTN","RAPM2",232,0) . . I RATYP="S" S ^TMP($J,"RAPM",RAN)=^TMP($J,"RAPM",RAN)_RADIV_$S($O(^TMP($J,"RA D-TYPE",RADIV))]"":", ",1:"") "RTN","RAPM2",233,0) . I $X>(RAIOM-$L("Division(s): ")) D "RTN","RAPM2",234,0) . . W:RAIO !?($X+$L("Division(s): ")) "RTN","RAPM2",235,0) . . I RATYP="S" S:'$G(RAP99) RAN=RAN+1,^TMP($J,"RAPM",RAN)=" " "RTN","RAPM2",236,0) Q "RTN","RAPM2",237,0) IMG ; List selected Imaging Type(s) "RTN","RAPM2",238,0) Q:'$D(^TMP($J,"RA I-TYPE")) "RTN","RAPM2",239,0) ;N RALMAX,RALUSED,RATAIL,RALDENT "RTN","RAPM2",240,0) S RALDENT=$L("Imaging Type(s): ") "RTN","RAPM2",241,0) S RALMAX=RAIOM-RALDENT "RTN","RAPM2",242,0) S RALUSED=0 "RTN","RAPM2",243,0) S RAIMG="" F J=1:1 S RAIMG=$O(^TMP($J,"RA I-TYPE",RAIMG)) Q:RAIMG="" D "RTN","RAPM2",244,0) . S RATAIL=$S($O(^TMP($J,"RA I-TYPE",RAIMG))]"":", ",1:"") "RTN","RAPM2",245,0) . I (RALUSED+$L(RAIMG)+$L(RATAIL))>RALMAX D "RTN","RAPM2",246,0) .. W:RAIO !?RALDENT "RTN","RAPM2",247,0) .. I RATYP="S",'$G(RAP99) S RAN=RAN+1,^TMP($J,"RAPM",RAN)=" " "RTN","RAPM2",248,0) .. S RALUSED=0 "RTN","RAPM2",249,0) .. Q "RTN","RAPM2",250,0) . W:RAIO RAIMG_RATAIL "RTN","RAPM2",251,0) . I RATYP="S",'$G(RAP99) S ^TMP($J,"RAPM",RAN)=^TMP($J,"RAPM",RAN)_RAIMG_RATAIL "RTN","RAPM2",252,0) . S RALUSED=RALUSED+$L(RAIMG)+$L(RATAIL) "RTN","RAPM2",253,0) Q "RTN","RAPMW2") 0^70^B79947106 "RTN","RAPMW2",1,0) RAPMW2 ;HOIFO/SWM-Radiology Wait Time reports ;12/05/05 13:41 "RTN","RAPMW2",2,0) ;;5.0;Radiology/Nuclear Medicine;**67,79,83,99,47**;Mar 16, 1998;Build 21 "RTN","RAPMW2",3,0) ; IA 10063 allows check for Task Stop Request "RTN","RAPMW2",4,0) ; detail "RTN","RAPMW2",5,0) Q "RTN","RAPMW2",6,0) STORDET ; "RTN","RAPMW2",7,0) S RAREC="" "RTN","RAPMW2",8,0) S RACNL=$E(RAXDT,4,5)_$E(RAXDT,6,7)_$E(RAXDT,2,3)_"-"_+RACN0 ;long CN "RTN","RAPMW2",9,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RAPMW2",10,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACNL) "RTN","RAPMW2",11,0) S RA71REC=$G(^RAMIS(71,+$P(RACN0,U,2),0)) "RTN","RAPMW2",12,0) S RAXMST=$P(RA72,U) ;exam status name "RTN","RAPMW2",13,0) S RACPT=$P($$NAMCODE^RACPTMSC($P(RA71REC,U,9),RAXDT),U) ;CPT code "RTN","RAPMW2",14,0) S RAPROCNM=$P(RA71REC,U) ;procedure name "RTN","RAPMW2",15,0) S RAPATNM=$$GET1^DIQ(2,RADFN,.01) S:RAPATNM="" RAPATNM=" " ;pt.name "RTN","RAPMW2",16,0) S RAPATNM=$E(RAPATNM,1,12) ;use 1st 12 chars of pat name "RTN","RAPMW2",17,0) S RAPATND=RAPATNM_"-"_RADFN ;patname-DFN "RTN","RAPMW2",18,0) S RADTORD=$P($P(RAOREC,U,16),".") ;date ordered "RTN","RAPMW2",19,0) ; store items in this order -- piece no.;field descrp/ "RTN","RAPMW2",20,0) ; 1;pt.name/ 2;long case no./ 3;dt ordered/ 4;dt desired/ 5;exam dt/ "RTN","RAPMW2",21,0) ; 6;no. days wait/ 7;exm stat name/ 8;CPT code/ 9; proc name/ "RTN","RAPMW2",22,0) ; 10;img typ name/ 11;* if canc & re-ord same day/ 12;Proc Typ Name/ "RTN","RAPMW2",23,0) ; 13;"p" if case from print set (highest ranked proc type) "RTN","RAPMW2",24,0) ; "RTN","RAPMW2",25,0) I $$USESSAN^RAHLRU1() S RAREC=RAPATNM_U_RACNDSP_U_$E(RADTORD,1,7)_U_$E(RADSDT,1,7) "RTN","RAPMW2",26,0) I '$$USESSAN^RAHLRU1() S RAREC=RAPATNM_U_RACNL_U_$E(RADTORD,1,7)_U_$E(RADSDT,1,7) "RTN","RAPMW2",27,0) S RAREC=RAREC_U_$E(RAXDT,1,7)_U_RAWAITD_U_$E(RAXMST,1,11)_U_RACPT "RTN","RAPMW2",28,0) S RAREC=RAREC_U_$E(RAPROCNM,1,45)_U_$E(RAIMGTYP,1,3)_U_$S(RASAME2:"*",1:"")_U_RAPTA "RTN","RAPMW2",29,0) S RAREC=RAREC_U_$S(RACNI=99999:"p",1:"") ;flag printset case picked "RTN","RAPMW2",30,0) ; subscript 3 is the sort value "RTN","RAPMW2",31,0) ; subscripts 4-6 combined should be unique to a case, prevent over- "RTN","RAPMW2",32,0) ; writing subscript 3 when >1 case has same sort value "RTN","RAPMW2",33,0) ; subscript 4 is the exam date in Fileman notation "RTN","RAPMW2",34,0) ; subcript 5 is the patient name (1st 12 chars) and DFN "RTN","RAPMW2",35,0) ; subscript 6 is the "P" level ien of file 70 "RTN","RAPMW2",36,0) I RASORT="CN" S ^TMP($J,"RA WAIT3",RACNL,RADTE,RAPATND,RACNISAV)=RAREC "RTN","RAPMW2",37,0) I RASORT="CPT" S ^TMP($J,"RA WAIT3",RACPT,RADTE,RAPATND,RACNISAV)=RAREC "RTN","RAPMW2",38,0) I RASORT="DD" S ^TMP($J,"RA WAIT3",RADSDT,RADTE,RAPATND,RACNISAV)=RAREC "RTN","RAPMW2",39,0) I RASORT="D" S ^TMP($J,"RA WAIT3",RAWAITD,RADTE,RAPATND,RACNISAV)=RAREC "RTN","RAPMW2",40,0) I RASORT="DO" S ^TMP($J,"RA WAIT3",RADTORD,RADTE,RAPATND,RACNISAV)=RAREC "RTN","RAPMW2",41,0) I RASORT="DR" S ^TMP($J,"RA WAIT3",RAXDT,RADTE,RAPATND,RACNISAV)=RAREC "RTN","RAPMW2",42,0) I RASORT="I" S ^TMP($J,"RA WAIT3",RAIMGTYP,RADTE,RAPATND,RACNISAV)=RAREC "RTN","RAPMW2",43,0) I RASORT="PT" S ^TMP($J,"RA WAIT3",RAPTA,RADTE,RAPATND,RACNISAV)=RAREC "RTN","RAPMW2",44,0) I RASORT="PN" S ^TMP($J,"RA WAIT3",RAPATNM,RADTE,RAPATND,RACNISAV)=RAREC "RTN","RAPMW2",45,0) I RASORT="PROC" S ^TMP($J,"RA WAIT3",RAPROCNM,RADTE,RAPATND,RACNISAV)=RAREC "RTN","RAPMW2",46,0) Q "RTN","RAPMW2",47,0) WRTDET ; "RTN","RAPMW2",48,0) S RAHD0="Detail",RAPG=1 "RTN","RAPMW2",49,0) D SETHD^RAPMW1 "RTN","RAPMW2",50,0) D PRTD Q:RAXIT "RTN","RAPMW2",51,0) D FOOTD "RTN","RAPMW2",52,0) Q "RTN","RAPMW2",53,0) HDDET ; "RTN","RAPMW2",54,0) W !!,"Sorted by: ",RASORTNM,?38,"Print only cases with minimum Days Wait of: ",RASINCE "RTN","RAPMW2",55,0) W !,"Total number of procedures registered during specified exam date range: ",RATOTAL "RTN","RAPMW2",56,0) Q "RTN","RAPMW2",57,0) COLHDD ; "RTN","RAPMW2",58,0) I RAPG>1 W @IOF,!,"Page: ",RAPG "RTN","RAPMW2",59,0) S RAPG=RAPG+1 "RTN","RAPMW2",60,0) W !!?31,"Date",?40,"Date",?49,"Date",?58,"Days",?63,"Exam",?75,"CPT",?123,"Img",?127,"PROC." "RTN","RAPMW2",61,0) W !,"Patient Name",?14,"Case #",?31,"Ordered",?40,"Desired",?49,"Register",?58,"Wait",?63,"Status",?75,"Code",?81,"Name of Procedure",?123,"Typ",?127,"TYPE" "RTN","RAPMW2",62,0) W !,$E(RADASH,1,12),?14,$E(RADASH,1,16),?31,$E(RADASH,1,8),?40,$E(RADASH,1,8),?49,$E(RADASH,1,8),?58,$E(RADASH,1,4),?63,$E(RADASH,1,11),?75,$E(RADASH,1,5),?81,$E(RADASH,1,41),?123,$E(RADASH,1,3),?127,$E(RADASH,1,5) "RTN","RAPMW2",63,0) I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 ;user stopped task "RTN","RAPMW2",64,0) Q "RTN","RAPMW2",65,0) PRTD ; "RTN","RAPMW2",66,0) I RATYP="B" D PRESS^RAPMW1 Q:RAXIT "RTN","RAPMW2",67,0) N X "RTN","RAPMW2",68,0) D HD^RAPMW1 Q:RAXIT D HDDET,COLHDD "RTN","RAPMW2",69,0) S RA0="",RAXIT=0 "RTN","RAPMW2",70,0) F S RA0=$O(^TMP($J,"RA WAIT3",RA0)) Q:RA0="" Q:RAXIT S RA1=0 D "RTN","RAPMW2",71,0) .F S RA1=$O(^TMP($J,"RA WAIT3",RA0,RA1)) Q:'RA1 Q:RAXIT S RA2=0 D "RTN","RAPMW2",72,0) ..F S RA2=$O(^TMP($J,"RA WAIT3",RA0,RA1,RA2)) Q:RA2="" Q:RAXIT S RA3=0 D "RTN","RAPMW2",73,0) ...F S RA3=$O(^TMP($J,"RA WAIT3",RA0,RA1,RA2,RA3)) Q:'RA3 Q:RAXIT S X=^(RA3) D "RTN","RAPMW2",74,0) ....D CKLINE Q:RAXIT "RTN","RAPMW2",75,0) ....W !,$P(X,U),?13,$P(X,U,13),?14,$P(X,U,2),?31,$$FMTE^XLFDT($P(X,U,3),2),?40,$$FMTE^XLFDT($P(X,U,4),2),?49,$$FMTE^XLFDT($P(X,U,5),2),$P(X,U,11),?58,$J($P(X,U,6),4),?63,$P(X,U,7) "RTN","RAPMW2",76,0) ....W ?75,$P(X,U,8),?81,$P(X,U,9),?123,$P(X,U,10),?127,$E($P(X,U,12),1,5) "RTN","RAPMW2",77,0) ....Q "RTN","RAPMW2",78,0) ...Q "RTN","RAPMW2",79,0) ..Q "RTN","RAPMW2",80,0) .Q "RTN","RAPMW2",81,0) Q "RTN","RAPMW2",82,0) CKLINE ; "RTN","RAPMW2",83,0) I ($Y+5)>IOSL D "RTN","RAPMW2",84,0) . S RAXIT=$$S^%ZTLOAD("This task was in routine RAPMW2 when it was stopped.") I RAXIT S ZTSTOP=1 Q ;IA10063 "RTN","RAPMW2",85,0) .D PRESS^RAPMW1 "RTN","RAPMW2",86,0) .Q:RAXIT "RTN","RAPMW2",87,0) .D COLHDD "RTN","RAPMW2",88,0) .Q "RTN","RAPMW2",89,0) Q "RTN","RAPMW2",90,0) FOOTD ; "RTN","RAPMW2",91,0) D PRESS^RAPMW1 Q:RAXIT W:$E(IOST,1,2)="C-" @IOF "RTN","RAPMW2",92,0) I RANEG W !!?3,"(There ",$S(RANEG=1:"is",1:"are")," ",RANEG," case",$S(RANEG=1:"",1:"s")," with negative days wait included in the listing.)",! "RTN","RAPMW2",93,0) F I=1:1:28 Q:RAXIT W !?4,$P($T(FOOTD2+I),";;",2) I ($Y+5)>IOSL D PRESS^RAPMW1 Q:RAXIT W:$E(IOST,1,2)="C-" @IOF "RTN","RAPMW2",94,0) Q "RTN","RAPMW2",95,0) CALC ; "RTN","RAPMW2",96,0) S RASAME2=0 ;=1 if exm's order was cancelled & reordered same day "RTN","RAPMW2",97,0) S RAORIEN=$P(RACN0,U,11) "RTN","RAPMW2",98,0) S RAOREC=$G(^RAO(75.1,+RAORIEN,0)) "RTN","RAPMW2",99,0) I RAOREC="" S ^TMP($J,"RA WAIT NO ORD",RADFN,RADTI,RACNI)=RAORIEN Q "RTN","RAPMW2",100,0) S RAXDT=9999999.9999-RADTI ; exam date FM format "RTN","RAPMW2",101,0) S RADSDT=$P(RAOREC,U,21) ; Date Desired "RTN","RAPMW2",102,0) I RADSDT="" S ^TMP($J,"RA WAIT NO DSR DT",RADFN,RADTI,RACNI)=RAORIEN Q "RTN","RAPMW2",103,0) S RAWAITD=$$FMDIFF^XLFDT(RAXDT,RADSDT) ;Wait days btw exm & desired dt "RTN","RAPMW2",104,0) S:RAWAITD<0 RANEG=RANEG+1 "RTN","RAPMW2",105,0) D STORSUM^RAPMW1 ;store summary counts for Summary, Detail, Both "RTN","RAPMW2",106,0) S RA16=$P(RAOREC,U,16) ; request entered dt/tm "RTN","RAPMW2",107,0) ; count if same proc cancelled and reordered same day "RTN","RAPMW2",108,0) S RA1=$E(RA16,1,7) "RTN","RAPMW2",109,0) ; loop start w Last Activity same date as order's entry date "RTN","RAPMW2",110,0) F S RA1=$O(^RAO(75.1,"AO",RA1)) Q:'RA1 Q:RA1>RA16 D "RTN","RAPMW2",111,0) .S RA2=0 F S RA2=$O(^RAO(75.1,"AO",RA1,RA2)) Q:'RA2 Q:RA2=RAORIEN D "RTN","RAPMW2",112,0) ..S RA3=^RAO(75.1,RA2,0) ;skip exm's order "RTN","RAPMW2",113,0) ..; other order is discontinued,same patient,same ordered procedure "RTN","RAPMW2",114,0) ..I $P(RA3,U,5)=1,$P(RA3,U,1)=RADFN,$P(RA3,U,2)=$P(RAOREC,U,2) S RASAME=RASAME+1,RASAME2=1 "RTN","RAPMW2",115,0) ..Q "RTN","RAPMW2",116,0) .Q "RTN","RAPMW2",117,0) ; store detail rows for Detail,Both IF days wait at least = RASINCE "RTN","RAPMW2",118,0) I "B^D"[RATYP,((RAWAITD<0)!(RAWAITD'120" "RTN","RAPMW2",134,0) .W !,"TYPE",?29,"Days",?37,"Days",?46,"Days",?55,"Days",?65,"Days",?73,"Days" "RTN","RAPMW2",135,0) .W !,"------------------------",?27,"------",?35,"------",?44,"------",?53,"------",?63,"------",?71,"------" "RTN","RAPMW2",136,0) .Q "RTN","RAPMW2",137,0) I X=2 D "RTN","RAPMW2",138,0) .W !,"PROCEDURE",?19,"<=14",?27,"<=30",?34,"31-60",?42,"61-90",?49,"91-120",?59,">120",?68,"ROW",?75,"Avg." "RTN","RAPMW2",139,0) .W !,"TYPE",?19,"Days",?27,"Days",?35,"Days",?43,"Days",?51,"Days",?59,"Days",?66,"TOTAL",?75,"Days" "RTN","RAPMW2",140,0) .W !,"---------------",?16,"-------",?24,"-------",?32,"-------",?40,"-------",?48,"-------",?56,"-------",?64,"-------",?72,"-------" "RTN","RAPMW2",141,0) .Q "RTN","RAPMW2",142,0) Q "RTN","RAPMW2",143,0) FOOTD2 ; "RTN","RAPMW2",144,0) ;; "RTN","RAPMW2",145,0) ;;1. Cancelled, "No Credit", inpatient cases, and not the highest modality of a printset are excluded from this report. "RTN","RAPMW2",146,0) ;; (See 3. below.) "RTN","RAPMW2",147,0) ;; "RTN","RAPMW2",148,0) ;;2. The "Days Wait" represent # of days from the Registered date (the date/time entered at the "Imaging Exam Date/Time:" prompt) "RTN","RAPMW2",149,0) ;; backwards to the Date Desired for the ordered procedure. The calculation is based on the number of different days and "RTN","RAPMW2",150,0) ;; not rounded off by hours. "RTN","RAPMW2",151,0) ;; "RTN","RAPMW2",152,0) ;;3. If the user did not select a specific CPT Code or Procedure Name, then the cases from a printset (group of cases that "RTN","RAPMW2",153,0) ;; share the same report) will have only the case with the highest ranked modality printed. Modalities are ranked "RTN","RAPMW2",154,0) ;; in this order, (1) being the highest: "RTN","RAPMW2",155,0) ;; (1) Interventional, (2) MRI, (3) CT, (4) Cardiac Stress test, (5) Nuc Med, (6) US, (7) Mammo, (8) General Rad (9) Other "RTN","RAPMW2",156,0) ;; However, all the cases from an examset (group of cases that have separate reports) will all be listed. "RTN","RAPMW2",157,0) ;; "RTN","RAPMW2",158,0) ;;4. "Procedure Types" are assigned by a national CPT code look-up table and may differ from locally defined "Imaging Types." "RTN","RAPMW2",159,0) ;; Therefore the number of procedures in each category may not be the same as other radiology management reports. "RTN","RAPMW2",160,0) ;; "RTN","RAPMW2",161,0) ;;5. Procedure Type of "unknown" refers to either cases that have no matching procedure type in the spreadsheet of CPT Codes "RTN","RAPMW2",162,0) ;; provided by the Office of Patient Care Services, or cases that are missing data for the procedure. "RTN","RAPMW2",163,0) ;; "RTN","RAPMW2",164,0) ;;6. CPT Code is not available for parent and broad procedures in the header section. CPT Code of the parent order's highest "RTN","RAPMW2",165,0) ;; ranked modality case will be printed in the line by line section. (See 3. above.) "RTN","RAPMW2",166,0) ;; "RTN","RAPMW2",167,0) ;;7. Date/Time Registered is the "Imaging Exam Date/Time" entered by the user during Registration. "RTN","RAPMW2",168,0) ;; "RTN","RAPMW2",169,0) ;;8. "*" under the "Date Register" column denotes the request was cancelled and re-ordered on the same day that it was cancelled. "RTN","RAPMW2",170,0) ;; "RTN","RAPMW2",171,0) ;;9. "p" under the "Case #" column, before the case number, denotes printset case with the highest ranked Procedure Type. "RTN","RAPRINT1") 0^43^B29745884 "RTN","RAPRINT1",1,0) RAPRINT1 ;HISC/FPT-Abnormal Exam Report (cont.) ;4/5/96 10:49 "RTN","RAPRINT1",2,0) ;;5.0;Radiology/Nuclear Medicine;**34,97,47**;Mar 16, 1998;Build 21 "RTN","RAPRINT1",3,0) DIV ; walk through tmp global, start with 'division' "RTN","RAPRINT1",4,0) Q:'$D(^TMP($J)) "RTN","RAPRINT1",5,0) N RAFIRST,RAPRTSET,RASAME,RACURR,RAPREV,L1 "RTN","RAPRINT1",6,0) S RADIVNME="" "RTN","RAPRINT1",7,0) F S RADIVNME=$O(^TMP($J,RADIVNME)) Q:RADIVNME=""!(RAOUT) D IT "RTN","RAPRINT1",8,0) Q "RTN","RAPRINT1",9,0) IT ; imaging type "RTN","RAPRINT1",10,0) S RAITNAME="" "RTN","RAPRINT1",11,0) F S RAITNAME=$O(^TMP($J,RADIVNME,RAITNAME)) Q:RAITNAME=""!(RAOUT) D DXNUM "RTN","RAPRINT1",12,0) Q "RTN","RAPRINT1",13,0) DXNUM ; diagnostic code number "RTN","RAPRINT1",14,0) S RAPREV="" ; Determine If Next Line Item is Related to Previous Line. "RTN","RAPRINT1",15,0) S I=0 "RTN","RAPRINT1",16,0) F S I=$O(^TMP($J,RADIVNME,RAITNAME,I)) Q:I'>0!(RAOUT) D PATNAME "RTN","RAPRINT1",17,0) Q "RTN","RAPRINT1",18,0) PATNAME ; patient name "RTN","RAPRINT1",19,0) S RAPATNME="" "RTN","RAPRINT1",20,0) F S RAPATNME=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME)) Q:RAPATNME=""!(RAOUT) D PATIEN "RTN","RAPRINT1",21,0) Q "RTN","RAPRINT1",22,0) PATIEN ; patient internal entry number "RTN","RAPRINT1",23,0) S J=0 "RTN","RAPRINT1",24,0) F S J=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J)) Q:J'>0!(RAOUT) D EXAMDATE "RTN","RAPRINT1",25,0) Q "RTN","RAPRINT1",26,0) EXAMDATE ; exam date "RTN","RAPRINT1",27,0) S K=0 "RTN","RAPRINT1",28,0) F S K=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J,K)) Q:K'>0!(RAOUT) D CASENUM "RTN","RAPRINT1",29,0) Q "RTN","RAPRINT1",30,0) CASENUM ; case number "RTN","RAPRINT1",31,0) S (RAPRTSET,RAFIRST)=0 ; Group PrintSet Exams for Printing. "RTN","RAPRINT1",32,0) S RASAME=0 ; Group Multiple Diagnoses of Same Exam for Printing. "RTN","RAPRINT1",33,0) S L1=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J,K,0)) "RTN","RAPRINT1",34,0) I L1>0,$P(^RADPT(J,"DT",K,"P",L1,0),U,25)=2 S RAFIRST=1 D "RTN","RAPRINT1",35,0) .I $O(^RADPT(J,"DT",K,"P",L1),-1) S RAFIRST=2 ; Not First PrintSet Exam. "RTN","RAPRINT1",36,0) S L=0 "RTN","RAPRINT1",37,0) F S L=$O(^TMP($J,RADIVNME,RAITNAME,I,RAPATNME,J,K,L)) Q:L'>0!(RAOUT) D "RTN","RAPRINT1",38,0) .D DECIDE S (RAFIRST,RAPRTSET)=0 "RTN","RAPRINT1",39,0) .S RAPREV=J_U_K_U_L ; This Represents Last Line Printed. "RTN","RAPRINT1",40,0) Q "RTN","RAPRINT1",41,0) DECIDE ; decide which entries to print "RTN","RAPRINT1",42,0) S RAEXAM(0)=^RADPT(J,"DT",K,"P",L,0) "RTN","RAPRINT1",43,0) I 'RAFIRST,$P(RAEXAM(0),U,25)=2 S RAPRTSET=1 ; Determine Descendants. "RTN","RAPRINT1",44,0) S RACURR=J_U_K_U_L ; Save Current Line Info to be Printed. "RTN","RAPRINT1",45,0) S RADIAG=$P(^RA(78.3,I,0),U) "RTN","RAPRINT1",46,0) S RADXCODE=$S($P(RAEXAM(0),U,13)=I:"(P)",1:"(S)") "RTN","RAPRINT1",47,0) I RASW D PRINT Q "RTN","RAPRINT1",48,0) I RADXCODE="(P)",$P(RAEXAM(0),U,20) Q "RTN","RAPRINT1",49,0) I RADXCODE="(P)",'$P(RAEXAM(0),U,20) D PRINT Q "RTN","RAPRINT1",50,0) I '$D(^RADPT(J,"DT",K,"P",L,"DX")) Q "RTN","RAPRINT1",51,0) S RASDXIEN=$O(^RADPT(J,"DT",K,"P",L,"DX","B",I,0)) I RASDXIEN'>0 Q "RTN","RAPRINT1",52,0) S RASDXDTE=$P(^RADPT(J,"DT",K,"P",L,"DX",RASDXIEN,0),U,2) "RTN","RAPRINT1",53,0) I RASDXDTE="" D PRINT "RTN","RAPRINT1",54,0) Q "RTN","RAPRINT1",55,0) PRINT ; print entries "RTN","RAPRINT1",56,0) I $Y+5>IOSL D HANG Q:RAOUT D HDR Q:RAOUT "RTN","RAPRINT1",57,0) I I1("DIV")="" W !?22,"Division: ",RADIVNME S I1("DIV")=RADIVNME "RTN","RAPRINT1",58,0) I I1("IT")="" W !?18,"Imaging Type: ",RAITNAME S I1("IT")=RAITNAME "RTN","RAPRINT1",59,0) I I1("DIV")'=RADIVNME!(I1("IT")'=RAITNAME) D HANG Q:RAOUT D HDR Q:RAOUT S I1("DIV")=RADIVNME S I1("IT")=RAITNAME D "RTN","RAPRINT1",60,0) .W !?22,"Division: ",RADIVNME "RTN","RAPRINT1",61,0) .W !?18,"Imaging Type: ",RAITNAME "RTN","RAPRINT1",62,0) .I I1("DX")=I W !?15,"Diagnostic Code: ",RADIAG W !?15,"----------------" D EXPRESS "RTN","RAPRINT1",63,0) I I1("DX")'=I W !?15,"Diagnostic Code: ",RADIAG W !?15,"----------------" D EXPRESS "RTN","RAPRINT1",64,0) S RADFN=J,RAPAT=$S($D(^DPT(J,0)):^(0),1:""),RASSN=$$SSN^RAUTL(RADFN,1) "RTN","RAPRINT1",65,0) S RAPAT=$S($P(RAPAT,U)]"":$P(RAPAT,U),1:"Not Found") "RTN","RAPRINT1",66,0) S Y=9999999.9999-K X ^DD("DD") S RAEXDT=Y "RTN","RAPRINT1",67,0) S RACASE=$P(RAEXAM(0),U) "RTN","RAPRINT1",68,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,K,L) "RTN","RAPRINT1",69,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACASE) "RTN","RAPRINT1",70,0) S RAWARD=$S($P(RAEXAM(0),U,6):$P(RAEXAM(0),U,6),1:"") "RTN","RAPRINT1",71,0) I RAWARD]"" S RAWARD=$S($D(^DIC(42,RAWARD,0)):$P(^(0),U),1:"") "RTN","RAPRINT1",72,0) I RAWARD']"" S RAWARD=$S($P(RAEXAM(0),U,8):$P(RAEXAM(0),U,8),1:"") I RAWARD]"" S RAWARD=$S($D(^SC(RAWARD,0)):$P(^(0),U),1:"Unknown") "RTN","RAPRINT1",73,0) S RAPROC=$P(RAEXAM(0),U,2) "RTN","RAPRINT1",74,0) S RAPROC=$S($D(^RAMIS(71,RAPROC,0)):$P(^(0),U),1:"Unknown") "RTN","RAPRINT1",75,0) S RAMD=$P(RAEXAM(0),U,14) "RTN","RAPRINT1",76,0) S RAMD=$S(RAMD="":"Unknown",$D(^VA(200,RAMD,0)):$P(^(0),U),1:"Unknown") "RTN","RAPRINT1",77,0) I RADXCODE="(S)",'$D(RASDXIEN) D SDX I '$D(RASDXDTE) K RADXCODE,RASDXDTE,RASDXIEN G PQ "RTN","RAPRINT1",78,0) I RAFIRST!'RAPRTSET D ; Print Patient Header Once for PrintSets. "RTN","RAPRINT1",79,0) .I RAPREV=RACURR Q ; Print Patient Header Once for Multiple Dx. "RTN","RAPRINT1",80,0) .W !! "RTN","RAPRINT1",81,0) .I RADXCODE="(P)" W $S($P(RAEXAM(0),U,20):"*",1:"") "RTN","RAPRINT1",82,0) .I RADXCODE="(S)" W $S(RASDXDTE]"":"*",1:"") "RTN","RAPRINT1",83,0) .W $E(RAPAT,1,30)_" -"_RASSN,?38,RADXCODE,?42,$E(RAWARD,1,15),?58,$E(RAMD,1,21) "RTN","RAPRINT1",84,0) ; Print Pat. Case# Once for Single Exam with Multiple Dx or "RTN","RAPRINT1",85,0) ; Once for PrintSets. "RTN","RAPRINT1",86,0) ; Once for different DX though same pat. case# "RTN","RAPRINT1",87,0) I (RAPREV'=RACURR)!(I1("DX")'=I)!RAPRTSET D "RTN","RAPRINT1",88,0) .W !?1 W:RAFIRST=1 "(+)" I (RAFIRST=2)!RAPRTSET W "(.)" "RTN","RAPRINT1",89,0) .I $$USESSAN^RAHLRU1() W ?4,"Case #",RACNDSP,?27,$E(RAPROC,1,34),?62,RAEXDT "RTN","RAPRINT1",90,0) .I '$$USESSAN^RAHLRU1() W ?6,"Case #",RACASE,?20,$E(RAPROC,1,39),?60,RAEXDT "RTN","RAPRINT1",91,0) I RADXCODE="(P)",'$P(^RADPT(J,"DT",K,"P",L,0),U,20) S $P(^(0),U,20)=DT "RTN","RAPRINT1",92,0) I RADXCODE="(S)",'$P(^RADPT(J,"DT",K,"P",L,"DX",RASDXIEN,0),U,2) S $P(^(0),U,2)=DT "RTN","RAPRINT1",93,0) S ^TMP($J,"RADLY",RADIVNME,RAITNAME)=+^TMP($J,"RADLY",RADIVNME,RAITNAME)+1,CNT=CNT+1 "RTN","RAPRINT1",94,0) PQ S I1("DX")=I "RTN","RAPRINT1",95,0) K RADXCODE,RASDXDTE,RASDXIEN "RTN","RAPRINT1",96,0) Q "RTN","RAPRINT1",97,0) EXPRESS ;output expression text "RTN","RAPRINT1",98,0) N RAXPRESS "RTN","RAPRINT1",99,0) S RAXPRESS=$$GET1^DIQ(757.01,$P($G(^RA(78.3,+I,0)),U,6),.01) "RTN","RAPRINT1",100,0) I RAXPRESS'="" W ?32,"(",RAXPRESS,")" "RTN","RAPRINT1",101,0) Q "RTN","RAPRINT1",102,0) HDR ; header "RTN","RAPRINT1",103,0) W:$Y>0 @IOF "RTN","RAPRINT1",104,0) W !?20,"<<<< ABNORMAL DIAGNOSTIC REPORT >>>>",?58,"Print Date: ",PDATE "RTN","RAPRINT1",105,0) W !?13,"(P=Primary Dx, S=Secondary Dx / '*' represents reprint)" "RTN","RAPRINT1",106,0) W !?(80-$L($G(RATRPTG))\2),$G(RATRPTG) "RTN","RAPRINT1",107,0) W !,"Patient Name",?42,"Ward/Clinic",?58,"Requesting Physician" "RTN","RAPRINT1",108,0) I $$USESSAN^RAHLRU1() W !?27,"Procedure",?60,"Exam Date",!,QQ "RTN","RAPRINT1",109,0) I '$$USESSAN^RAHLRU1() W !?20,"Procedure",?60,"Exam Date",!,QQ "RTN","RAPRINT1",110,0) S I1("DIV")="",I1("IT")="" "RTN","RAPRINT1",111,0) I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1 "RTN","RAPRINT1",112,0) Q "RTN","RAPRINT1",113,0) HANG ; hold screen "RTN","RAPRINT1",114,0) K DIR,DIROUT,DIRUT,DTOUT,DUOUT "RTN","RAPRINT1",115,0) I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR "RTN","RAPRINT1",116,0) S:$D(DIRUT) RAOUT=1 "RTN","RAPRINT1",117,0) Q "RTN","RAPRINT1",118,0) SDX ; secondary dx ien and date "RTN","RAPRINT1",119,0) I '$D(^RADPT(J,"DT",K,"P",L,"DX")) Q "RTN","RAPRINT1",120,0) S RASDXIEN=$O(^RADPT(J,"DT",K,"P",L,"DX","B",I,0)) "RTN","RAPRINT1",121,0) Q:RASDXIEN'>0 "RTN","RAPRINT1",122,0) S RASDXDTE=$P(^RADPT(J,"DT",K,"P",L,"DX",RASDXIEN,0),U,2) "RTN","RAPRINT1",123,0) Q "RTN","RAPROD") 0^44^B45447427 "RTN","RAPROD",1,0) RAPROD ;HISC/FPT,GJC AISC/MJK-Detailed Exam View ;05/13/09 06:45 "RTN","RAPROD",2,0) ;;5.0;Radiology/Nuclear Medicine;**10,35,45,56,99,47**;Mar 16, 1998;Build 21 "RTN","RAPROD",3,0) ;Supported IA #2056 GET1^DIQ "RTN","RAPROD",4,0) ;Supported IA #2053 UPDATE^DIE "RTN","RAPROD",5,0) ;Supported IA #10040 ^SC( "RTN","RAPROD",6,0) ;Supported IA #10060 ^VA(200 "RTN","RAPROD",7,0) START S RADI=^RADPT(RADFN,"DT",RADTI,0) S:$D(^("P",RACNI,"COMP")) RA("COMP")=^("COMP") S RA("REA")=$S($D(^("R")):^("R"),1:"") "RTN","RAPROD",8,0) S RA("TECH")=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) I RA("TECH") S RA("TECH")=$S($D(^VA(200,+^(RA("TECH"),0),0)):$P(^(0),"^"),1:"") "RTN","RAPROD",9,0) S X=$P(Y(0),"^",4),RA("CAT")=$S(X="I":"INPATIENT",X="O":"OUTPATIENT",X="S":"SHARING",X="C":"CONTRACT",X="R":"RESEARCH",X="E":"EMPLOYEE",1:"UNKNOWN") "RTN","RAPROD",10,0) S RA("RST")=$$RSTAT^RAO7PC1A "RTN","RAPROD",11,0) F I=1:1:13 S Y=$T(LIST+I),@$P(Y,";",3)=$S($D(@($P(Y,";",4)_+$P(@$P(Y,";",5),"^",$P(Y,";",6))_",0)")):$P(^(0),"^"),1:"") "RTN","RAPROD",12,0) ; "RTN","RAPROD",13,0) N RAOPRC ; this will be the Requested Procedure defined only if it "RTN","RAPROD",14,0) ; differs from the Registered Procedure "RTN","RAPROD",15,0) I +$P(Y(0),U,11),($$DPROC^RAUTL15(RADFN,RADTI,RACNI,+$P(Y(0),U,11))]"") D "RTN","RAPROD",16,0) . S RAOPRC=$$GET1^DIQ(75.1,+$P(Y(0),"^",11)_",",2) "RTN","RAPROD",17,0) . Q "RTN","RAPROD",18,0) VIEW W @IOF S X="",$P(X,"=",80)="" W X K X "RTN","RAPROD",19,0) W !?2,"Name : ",RANME," ",RASSN "RTN","RAPROD",20,0) W !?2,"Division : ",$E(RA("DIV"),1,20),?40,"Category : ",RA("CAT") "RTN","RAPROD",21,0) W !?2,"Location : ",$S($D(^SC(+RA("LOC"),0)):$P(^(0),"^"),1:"Unknown"),?40,"Ward : ",$E(RA("WRD"),1,24) "RTN","RAPROD",22,0) W !?2,"Exam Date : ",RADATE,?40,"Service : ",$E(RA("SERV"),1,24) "RTN","RAPROD",23,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RAPROD",24,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN) "RTN","RAPROD",25,0) I $$USESSAN^RAHLRU1() W !?2,"Case No. : ",RACNDSP W ?40,"Bedsection : ",$E(RA("BED"),1,24) "RTN","RAPROD",26,0) I '$$USESSAN^RAHLRU1() W !?2,"Case No. : ",RACN W ?40,"Bedsection : ",$E(RA("BED"),1,24) "RTN","RAPROD",27,0) W !?40,"Clinic : ",$E(RA("CL"),1,24) "RTN","RAPROD",28,0) S Y=$E(RA("CAT")) I "CSR"[Y W !?40,$E($S("C"=Y:"Contract : "_RA("CONT"),"S"=Y:"Sharing : "_RA("CONT"),"R"=Y:"Research : "_RA("REA"),1:""),1,38) "RTN","RAPROD",29,0) W:$X>1 ! S X="",$P(X,"-",80)="" W X K X "RTN","RAPROD",30,0) W !?2,"Registered : ",$E(RAPRC,1,60) D PRCCPT "RTN","RAPROD",31,0) W:$G(RAOPRC)]"" !?2,"Requested : ",$E(RAOPRC,1,60) "RTN","RAPROD",32,0) W !?2,"Requesting Phy: ",$E(RA("PHY"),1,20),?40,"Exam Status : ",$S($D(^RA(72,RAST,0)):$E($P(^(0),"^"),1,24),1:"") "RTN","RAPROD",33,0) W !?2,"Int'g Resident: ",$E(RA("RES"),1,20),?40,"Report Status: ",$E(RA("RST"),1,21) "RTN","RAPROD",34,0) S RAPREVER=+$P($G(^RARPT(RARPT,0)),"^",13) "RTN","RAPROD",35,0) W !?2,"Pre-Verified : ",$E($S($D(^VA(200,RAPREVER,0)):$P(^(0),"^",1),1:"NO"),1,20),?40,"Cam/Equip/Rm : ",$E(RA("RM"),1,20) K RAPREVER "RTN","RAPROD",36,0) W !?2,"Int'g Staff : ",$E(RA("STAFF"),1,20),?40,"Diagnosis : ",$E(RA("DIA"),1,24) "RTN","RAPROD",37,0) W !?2,"Technologist : ",$E(RA("TECH"),1,20),?40,"Complication : ",$E(RA("CMP"),1,24) "RTN","RAPROD",38,0) I $D(RA("COMP")) W !?2,"Comment : " F I=1:60 Q:$E(RA("COMP"),I,I+59)']"" W ?18,$E(RA("COMP"),I,I+59) "RTN","RAPROD",39,0) ;W:$X>1 ! "RTN","RAPROD",40,0) W ! "RTN","RAPROD",41,0) I $$PTSEX^RAUTL8(RADFN)="F" D ;get pt sex and display pregnancy status for females, ptch #99 "RTN","RAPROD",42,0) .N RAOR751 S RAOR751=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,11) "RTN","RAPROD",43,0) .W ?2,"Pregnant at time of order entry: ",$$GET1^DIQ(75.1,$G(RAOR751)_",",13) "RTN","RAPROD",44,0) K RAFL W ?47,"Films :" F I=0:0 S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"F",I)) Q:I'>0 I $D(^(I,0)) S X=^(0) W ?55,$S($D(^RA(78.4,+$P(X,"^"),0)):$P(^(0),"^"),1:"Unknown")," - ",+$P(X,"^",2),! "RTN","RAPROD",45,0) W:$X>1 ! S X="",$P(X,"-",34)="" W X "RTN","RAPROD",46,0) W "Modifiers" W $E(X,1,32) K X "RTN","RAPROD",47,0) W !?2,"Proc Modifiers:" D MODS^RAUTL2 F I=1:1 Q:$P(Y,", ",I)']"" W ?18,$P(Y,", ",I),! "RTN","RAPROD",48,0) N J "RTN","RAPROD",49,0) W !?2,"CPT Modifiers : " W:Y(1)="None" Y(1),! "RTN","RAPROD",50,0) I Y(1)'="None" F I=1:1 Q:$P(Y(2),", ",I)']"" S J=$P(Y(2),", ",I),J=$$BASICMOD^RACPTMSC(J,DT) W ?18,$P(J,"^",2)," ",$P(J,"^",3),! I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF W ! "RTN","RAPROD",51,0) Q:+$G(RAXIT) "RTN","RAPROD",52,0) I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF W ! "RTN","RAPROD",53,0) Q:+$G(RAXIT) "RTN","RAPROD",54,0) ; "RTN","RAPROD",55,0) ;check for Contrast Media data, print it if it exists. "RTN","RAPROD",56,0) I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0)) D "RTN","RAPROD",57,0) .W !?2,"Contrast Media: " S RACM=1 "RTN","RAPROD",58,0) .N DIWF,DIWL,DIWR,DIWT,X,Z "RTN","RAPROD",59,0) .S X=$$CM^RADEM1(RADFN,RADTI,RACNI),DIWL=20,DIWF="C50" "RTN","RAPROD",60,0) .D ^DIWP S Z=0 "RTN","RAPROD",61,0) .F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:'Z D "RTN","RAPROD",62,0) ..W ?18,^UTILITY($J,"W",DIWL,Z,0) "RTN","RAPROD",63,0) ..W:+$O(^UTILITY($J,"W",DIWL,Z)) ! "RTN","RAPROD",64,0) ..Q "RTN","RAPROD",65,0) .K ^UTILITY($J,"W") "RTN","RAPROD",66,0) .Q "RTN","RAPROD",67,0) ; "RTN","RAPROD",68,0) I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) D PHARM^RAPROD2(RACNI_","_RADTI_","_RADFN_",") W ! ; display pharmaceutical data "RTN","RAPROD",69,0) I +$G(RAXIT) K RAXIT Q "RTN","RAPROD",70,0) I +$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",28) D RDIO^RAPROD2(+$P(^(0),"^",28)) W ! ; display radiopharm data "RTN","RAPROD",71,0) I +$G(RAXIT) K RAXIT Q "RTN","RAPROD",72,0) W:$X>1 ! S X="",$P(X,"=",80)="" W X K X "RTN","RAPROD",73,0) G ^RAPROD1 "RTN","RAPROD",74,0) ; "RTN","RAPROD",75,0) PRCCPT ; display Proc's abbrv, proc type, CPT "RTN","RAPROD",76,0) Q:$G(RADTI)="" Q:$G(RACNI)="" "RTN","RAPROD",77,0) ; "RTN","RAPROD",78,0) N RADISPLY "RTN","RAPROD",79,0) S RADISPLY=$G(^RAMIS(71,+$P($G(^RADPT(+RADFN,"DT",+RADTI,"P",+RACNI,0)),U,2),0)) ; set $ZR to file 71 before calling prccpt^radd1 "RTN","RAPROD",80,0) S RADISPLY=$$PRCCPT^RADD1() "RTN","RAPROD",81,0) W ?54,RADISPLY "RTN","RAPROD",82,0) Q "RTN","RAPROD",83,0) SETL ;Set long display preference "RTN","RAPROD",84,0) N RA1,RA2,DIR "RTN","RAPROD",85,0) S RA1=$O(^RA(79,0)) Q:'RA1 "RTN","RAPROD",86,0) S RA2=$O(^RA(79,RA1,"LDIS","B",DUZ,0)) "RTN","RAPROD",87,0) I RA2 D Q "RTN","RAPROD",88,0) . W !!,"Your preference for Long Display of Procedures has already been set." "RTN","RAPROD",89,0) . S DIR(0)="Y",DIR("A")="Do you want to delete your preference ",DIR("B")="No" "RTN","RAPROD",90,0) . S DIR("?",1)="If you answer 'Yes', then all Radiology reports requested by you will" "RTN","RAPROD",91,0) . S DIR("?",2)="will default to the condensed display, which means that repeated procedures" "RTN","RAPROD",92,0) . S DIR("?")="and associated modifiers will only be listed once." "RTN","RAPROD",93,0) . D ^DIR "RTN","RAPROD",94,0) . Q:'Y "RTN","RAPROD",95,0) . D DEL150 "RTN","RAPROD",96,0) . Q "RTN","RAPROD",97,0) W ! "RTN","RAPROD",98,0) S DIR(0)="Y",DIR("A",1)="Do you want to set your preference for Long Display of Procedures" "RTN","RAPROD",99,0) S DIR("A")="in all Radiology reports ",DIR("B")="No" "RTN","RAPROD",100,0) S DIR("?",1)="If you answer 'Yes', then all Radiology reports requested by you will" "RTN","RAPROD",101,0) S DIR("?",2)="list all repeated procedures and associated modifiers instead of" "RTN","RAPROD",102,0) S DIR("?")="listing repeated procedures only once, which is the condensed (default) format." "RTN","RAPROD",103,0) D ^DIR "RTN","RAPROD",104,0) Q:'Y "RTN","RAPROD",105,0) D STUF150 "RTN","RAPROD",106,0) Q "RTN","RAPROD",107,0) DEL150 ;Delete user ien from 1st record in file 79's field 150 "RTN","RAPROD",108,0) ; note: DIK utility looks for DA(1) here "RTN","RAPROD",109,0) Q:'$D(DUZ)#2 "RTN","RAPROD",110,0) S DA(1)=$O(^RA(79,0)) Q:'DA(1) "RTN","RAPROD",111,0) S DIK="^RA(79,"_DA(1)_",""LDIS""," "RTN","RAPROD",112,0) S DA=$O(^RA(79,DA(1),"LDIS","B",DUZ,0)) "RTN","RAPROD",113,0) Q:'DA "RTN","RAPROD",114,0) D ^DIK "RTN","RAPROD",115,0) K DIK,DA "RTN","RAPROD",116,0) W !!,"Your preference for Long Display of Procedures has been removed.",! "RTN","RAPROD",117,0) Q "RTN","RAPROD",118,0) STUF150 ;Stuff user ien into 1st record in file 79's field 150 "RTN","RAPROD",119,0) Q:'$D(DUZ)#2 "RTN","RAPROD",120,0) S RA1=$O(^RA(79,0)) Q:'RA1 "RTN","RAPROD",121,0) K RAFDA,RAIEN,RAMSG "RTN","RAPROD",122,0) S RAFDA(79.03,"?+2,"_RA1_",",.01)=DUZ "RTN","RAPROD",123,0) D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") "RTN","RAPROD",124,0) W !!,"Your preference for Long Display of Procedures has been set.",! "RTN","RAPROD",125,0) Q "RTN","RAPROD",126,0) CDIS ; set up RACDIS array to store 1st non-duplicate proc+pmod+cptmod "RTN","RAPROD",127,0) N N1,N2,R1,RA71,Y "RTN","RAPROD",128,0) K RACDIS "RTN","RAPROD",129,0) D LDIS "RTN","RAPROD",130,0) S N1=0 "RTN","RAPROD",131,0) F S N1=$O(^RADPT(RADFN,"DT",RADTI,"P",N1)) Q:'N1 S R1=$G(^(N1,0)) D:R1]"" "RTN","RAPROD",132,0) . S RA71=$P(R1,U,2),RACNI=N1 "RTN","RAPROD",133,0) . D MODS^RAUTL2 "RTN","RAPROD",134,0) . S RACDIS("B",RA71,Y,Y(1),N1)="" "RTN","RAPROD",135,0) . S N2=$O(RACDIS("B",RA71,Y,Y(1),0)) "RTN","RAPROD",136,0) . S RACDIS(N2)=$G(RACDIS(N2))+1 ;increment lowest ien of same proc+pmod+cptmod "RTN","RAPROD",137,0) . S:RACDIS(N2)>1 RACDIS("RAFLDUP")=1 ;>1 same proc+pmod+cptmod "RTN","RAPROD",138,0) . Q "RTN","RAPROD",139,0) Q "RTN","RAPROD",140,0) LDIS ; See if user prefers Long Display of Procedures "RTN","RAPROD",141,0) N RA1 "RTN","RAPROD",142,0) S RA1=$O(^RA(79,0)) Q:'RA1 "RTN","RAPROD",143,0) S:$O(^RA(79,RA1,"LDIS","B",DUZ,0)) RALDIS=1 "RTN","RAPROD",144,0) Q "RTN","RAPROD",145,0) LIST ; "RTN","RAPROD",146,0) ;;RA("DIV");^DIC(4,;RADI;3 "RTN","RAPROD",147,0) ;;RA("LOC");^RA(79.1,;RADI;4 "RTN","RAPROD",148,0) ;;RA("WRD");^DIC(42,;Y(0);6 "RTN","RAPROD",149,0) ;;RA("SERV");^DIC(49,;Y(0);7 "RTN","RAPROD",150,0) ;;RA("CL");^SC(;Y(0);8 "RTN","RAPROD",151,0) ;;RA("CONT");^DIC(34,;Y(0);9 "RTN","RAPROD",152,0) ;;RA("RES");^VA(200,;Y(0);12 "RTN","RAPROD",153,0) ;;RA("DIA");^RA(78.3,;Y(0);13 "RTN","RAPROD",154,0) ;;RA("PHY");^VA(200,;Y(0);14 "RTN","RAPROD",155,0) ;;RA("STAFF");^VA(200,;Y(0);15 "RTN","RAPROD",156,0) ;;RA("CMP");^RA(78.1,;Y(0);16 "RTN","RAPROD",157,0) ;;RA("RM");^RA(78.6,;Y(0);18 "RTN","RAPROD",158,0) ;;RA("BED");^DIC(42.4,;Y(0);19 "RTN","RAPROS") 0^45^B29816651 "RTN","RAPROS",1,0) RAPROS ;HISC/GJC AISC/MJK,RMO-Exam Profile (sort) ;6/19/97 09:12 "RTN","RAPROS",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21 "RTN","RAPROS",3,0) PAT S DIC(0)="AQEM" D ^RADPA K DIC G Q:Y<0 S RADFN=+Y G Q:'$D(^DPT(RADFN,0)) S RANME=^(0),RASSN=$$SSN^RAUTL,RANME=$P(RANME,"^") "RTN","RAPROS",4,0) SORT R !!,"Sort by one of the following:",!?10,"P ==> Procedure",!?10,"D ==> Date of Exam",!?30,"Procedure// ",RAXX:DTIME "RTN","RAPROS",5,0) G Q:'$T!(RAXX["^") S RAXX=$E(RAXX) S:RAXX="" RAXX="P" G SORT:RAXX="?" S RAXX=$$UP^XLFSTR(RAXX) I "PD"'[RAXX W *7," ??" G SORT "RTN","RAPROS",6,0) I RAXX="D" S RASORT="RADTI" D DATE^RAUTL G Q:RAPOP S BEG=9999999-ENDDATE,END=9999999.9999-BEGDATE G ZIS "RTN","RAPROS",7,0) ASKSRT S RASORT="RAPRI" "RTN","RAPROS",8,0) W ! K DIR S DIR(0)="YA",DIR("B")="Yes" "RTN","RAPROS",9,0) S DIR("?")="Enter 'Y' to select a specific procedure, or 'No' not to." "RTN","RAPROS",10,0) S DIR("A")="Do you wish to look for a specific procedure? " "RTN","RAPROS",11,0) D ^DIR K DIR G:$D(DIRUT) Q "RTN","RAPROS",12,0) S:'+Y BEG=0,END=999999 D:+Y PROC G:+Y=-1 Q "RTN","RAPROS",13,0) ZIS ; Device selection "RTN","RAPROS",14,0) W ! S RAPRT=1,ZTRTN="START^RAPROS" F RASV="RANME","RASSN","BEG","END","RADFN","RASORT","RAPRT","^TMP($J,""RA I-TYPE"",","RAXX" S ZTSAVE(RASV)="" "RTN","RAPROS",15,0) S ZTDESC="Rad/Nuc Med Exam Profile" D ZIS^RAUTL G Q:RAPOP "RTN","RAPROS",16,0) S:IO=IO(0) RAPRT=0 "RTN","RAPROS",17,0) START S RAX="" K ^TMP($J,"RASORT"),^("RASEQ") S (RAPAG,RASEQ)=0 "RTN","RAPROS",18,0) F RADTI=0:0 S RADTI=$O(^RADPT(RADFN,"DT",RADTI)) Q:RADTI'>0 D "RTN","RAPROS",19,0) . I $D(^RADPT(RADFN,"DT",RADTI,0)) S RAZERO=$G(^(0)) D "RTN","RAPROS",20,0) .. S RAELOC=$P($G(^SC(+$P($G(^RA(79.1,+$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,4),0)),U),0)),U) "RTN","RAPROS",21,0) .. S RADTPRT=+$P(RAZERO,U),RADTPRT=$E(RADTPRT,4,5)_"/"_$E(RADTPRT,6,7)_"/"_$E(RADTPRT,2,3) "RTN","RAPROS",22,0) .. S (RADTE,Y)=+$P(RAZERO,"^") D D^RAUTL S RADATE=Y "RTN","RAPROS",23,0) .. D RACN "RTN","RAPROS",24,0) .. Q "RTN","RAPROS",25,0) . Q "RTN","RAPROS",26,0) I '$D(^TMP($J,"RASORT")) W !!?5,"For the above criteria, no registered exams filed for patient...",!?30,"...",RANME," ",RASSN,".",! G Q1 "RTN","RAPROS",27,0) U IO D PRT D CLOSE^RAUTL I RAX'=""!(RAPRT) D Q G ST2 "RTN","RAPROS",28,0) ST1 W !,"CHOOSE FROM 1-",RASEQ,": " R RAX:DTIME I RAX["?" D HLP G ST1 "RTN","RAPROS",29,0) I RAX,'$D(^TMP($J,"RASEQ",RAX)) W !,*7,"You may only select one exam at a time. Choose a number between 1 and ",RASEQ,"." G ST1 "RTN","RAPROS",30,0) ST2 G Q1:'RAX S Y=^TMP($J,"RASEQ",RAX) F I=1:1:11 S @$P("RACN^RAPRC^RADATE^RAST^RADFN^RADTI^RACNI^RANME^RASSN^RADTE^RARPT","^",I)=$P(Y,"^",I) "RTN","RAPROS",31,0) S Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) D ^RAPROD D Q1 G PAT "RTN","RAPROS",32,0) Q1 K RAX,^TMP($J,"RASORT"),^("RASEQ") "RTN","RAPROS",33,0) Q ; Kill and quit "RTN","RAPROS",34,0) K %,%W,%Y,%Y1,BEG,BEGDATE,C,DIROUT,DIRUT,DTOUT,DUOUT,END,ENDDATE,POP "RTN","RAPROS",35,0) K RAPOP,RAA,RACN,RACNI,RADATE,RADFN,RADTE,RADTI,RAI,RAII,RANME,RASSN "RTN","RAPROS",36,0) K RAPRC,RAPRT,RARPT,RASEQ,RASORT,RAST,RAPAG,RAZERO,RAXX,RAY,RAPRI,RASV "RTN","RAPROS",37,0) K RADTPRT,RAELOC,X,Y,ZTDESC,ZTRTN,ZTSAVE "RTN","RAPROS",38,0) K RAXIT,RAMES "RTN","RAPROS",39,0) Q "RTN","RAPROS",40,0) RACN ; Get the case numbers. "RTN","RAPROS",41,0) F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 I $D(^(RACNI,0)) S Y=^(0) D STORE "RTN","RAPROS",42,0) Q "RTN","RAPROS",43,0) STORE ; Store data in the ^TMP global "RTN","RAPROS",44,0) S RAPRI=+$P(Y,"^",2),RAPRC=99 S:$D(^RAMIS(71,RAPRI,0)) RAPRC=$P(^(0),"^") "RTN","RAPROS",45,0) S RAST=+$P(Y,"^",3),RACN=+Y,RARPT=+$P(Y,"^",17) "RTN","RAPROS",46,0) I @RASORT>BEG,@RASORT0) S RAA=$O(^TMP($J,"RASORT",RAA)) Q:RAA="" F RAII=0:0 S RAII=$O(^TMP($J,"RASORT",RAA,RAII)) Q:RAII'>0 S RAY=^(RAII) D PRT1 Q:RAX="^"!(RAX>0) "RTN","RAPROS",50,0) Q "RTN","RAPROS",51,0) PRT1 G PRT2:RAPRT!(RASEQ#15)!('RASEQ) I '(RASEQ#15) W !,"Type '^' to STOP, or",!,"CHOOSE FROM 1-",RASEQ,": " R RAX:DTIME G PRT3:RAX="" Q:RAX["^" I RAX["?" D HLP G PRT1 "RTN","RAPROS",52,0) I '$D(^TMP($J,"RASEQ",RAX)) W !,*7,"You may only select one exam at a time. Choose a number between 1 and ",RASEQ,"." G PRT1 "RTN","RAPROS",53,0) S RAX=+RAX Q "RTN","RAPROS",54,0) PRT2 I ($Y+4)>IOSL,RAPRT D HD "RTN","RAPROS",55,0) PRT3 S RASEQ=RASEQ+1,^TMP($J,"RASEQ",RASEQ)=RAY "RTN","RAPROS",56,0) N RADFN,RADTI,RACNI "RTN","RAPROS",57,0) S RADFN=$P(RAY,"^",5),RADTI=$P(RAY,"^",6),RACNI=$P(RAY,"^",7) "RTN","RAPROS",58,0) N RAPRTSET,RAMEMLOW D EN1^RAUTL20 "RTN","RAPROS",59,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RAPROS",60,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:$P(RAY,"^")) "RTN","RAPROS",61,0) I $$USESSAN^RAHLRU1() D "RTN","RAPROS",62,0) .W !,RASEQ W:RASORT="RADTI" ?4,$S(RAMEMLOW:"+",RAPRTSET:".",1:" ") "RTN","RAPROS",63,0) .W ?5,RACNDSP,?10,$$IMGDISP^RAPTLU(+$P(RAY,"^",11)) "RTN","RAPROS",64,0) .W ?22,$E($P(RAY,"^",2),1,26),?49,$P(RAY,U,12) "RTN","RAPROS",65,0) .W ?58,$S($D(^RA(72,$P(RAY,"^",4),0)):$E($P(^(0),"^"),1,11),1:"Unknown") "RTN","RAPROS",66,0) .W ?70,$E($P(RAY,U,13),1,10) "RTN","RAPROS",67,0) I '$$USESSAN^RAHLRU1() D "RTN","RAPROS",68,0) .W !,RASEQ W:RASORT="RADTI" ?5,$S(RAMEMLOW:"+",RAPRTSET:".",1:" ") "RTN","RAPROS",69,0) .W ?6,$P(RAY,"^"),?11,$$IMGDISP^RAPTLU(+$P(RAY,"^",11)) "RTN","RAPROS",70,0) .W ?13,$E($P(RAY,"^",2),1,26),?41,$P(RAY,U,12) "RTN","RAPROS",71,0) .W ?52,$S($D(^RA(72,$P(RAY,"^",4),0)):$E($P(^(0),"^"),1,16),1:"Unknown") "RTN","RAPROS",72,0) .W ?69,$E($P(RAY,U,13),1,11) "RTN","RAPROS",73,0) Q "RTN","RAPROS",74,0) HD ; Generic header output "RTN","RAPROS",75,0) W:$E(IOST,1,2)="C-"!(RAPAG) @IOF "RTN","RAPROS",76,0) W "Profile for ",RANME," ",RASSN,?55,"Run Date: " S Y=DT D DT^DIO2 W !!,?20,"***** Registered Exams Profile *****" "RTN","RAPROS",77,0) I $$USESSAN^RAHLRU1() W !?4,"Case No.",?22,"Procedure",?49,"Exam Dt",?58,"Exam Status",?70,"Img Loc",!?4,"-----------------",?22,"-------------",?49,"--------",?58,"-----------",?70,"----------" Q "RTN","RAPROS",78,0) I '$$USESSAN^RAHLRU1() W !?3,"Case No.",?13,"Procedure",?41,"Exam Date",?52,"Status of Exam",?69,"Imaging Loc",!?3,"--------",?13,"-------------",?41,"---------",?52,"------------",?69,"-----------" Q "RTN","RAPROS",79,0) HLP ; Generic help "RTN","RAPROS",80,0) W !!?3,"Enter the number corresponding to the exam you wish to select.",! "RTN","RAPROS",81,0) Q "RTN","RAPROS",82,0) PROC ; Select Procedure "RTN","RAPROS",83,0) N %,%Y,C,DA,DDH,DIC,X "RTN","RAPROS",84,0) S DIC="^RAMIS(71,",DIC(0)="QEAMZ",DIC("A")="Select Procedure: " "RTN","RAPROS",85,0) W !! D ^DIC "RTN","RAPROS",86,0) S:+Y>0 BEG=Y-1,END=Y+1 "RTN","RAPROS",87,0) Q "RTN","RAPTLU") 0^46^B37279557 "RTN","RAPTLU",1,0) RAPTLU ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Patient's Exam Lookup ;11/13/00 09:13 "RTN","RAPTLU",2,0) ;;5.0;Radiology/Nuclear Medicine;**2,8,15,23,56,47**;Mar 16, 1998;Build 21 "RTN","RAPTLU",3,0) ;Supported EA #10001 DT^DIO2 "RTN","RAPTLU",4,0) ;Supported IA #2378 ORCHK^GMRAOR "RTN","RAPTLU",5,0) ;Supported IA #10035 ^DPT( "RTN","RAPTLU",6,0) ;Supported IA #10040 ^SC( "RTN","RAPTLU",7,0) ;Private IA #1123 RACHK^GMRARAD, RADD^GMRARAD "RTN","RAPTLU",8,0) ;*********************************************************************** "RTN","RAPTLU",9,0) ; <<< NOTE >>> "RTN","RAPTLU",10,0) ; 'RANOSCRN' is set in the entry actions of various options. "RTN","RAPTLU",11,0) ; If the variable exists, the screen is ignored. Code is in line "RTN","RAPTLU",12,0) ; label PRT+0. "RTN","RAPTLU",13,0) ;*********************************************************************** "RTN","RAPTLU",14,0) CASE ; "RTN","RAPTLU",15,0) N RAHDCNT S RAHDCNT=0 D SEL S:'RACNT X="^" G Q:X="^"!($D(RAF1)) F I=1:1:11 S @$P("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",I)=$P(Y,"^",I) "RTN","RAPTLU",16,0) S ^DISV($S($D(DUZ)#2:DUZ,1:0),"RA","CASE #")=RADFN_"^"_RADTI_"^"_RACNI,Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) "RTN","RAPTLU",17,0) Q K RTESC,RTFL,RACNT,RAERR,RASTP,RAELOC,RADTPRT,^TMP("MAG",$J,"COL"),^TMP("MAG",$J,"ROW") Q "RTN","RAPTLU",18,0) ; "RTN","RAPTLU",19,0) SEL ; "RTN","RAPTLU",20,0) ;Q:'$D(^DPT(RADFN,0)) S RANME=^(0),RASSN=$$SSN^RAUTL,RANME=$P(RANME,"^") K ^TMP($J,"RAEX") D HOME^%ZIS D HD S X="",RACNT=0 "RTN","RAPTLU",21,0) Q:'$D(^DPT(RADFN,0)) S RANME=^(0),RASSN=$$SSN^RAUTL,RANME=$P(RANME,"^") K ^TMP($J,"RAEX") D HOME^%ZIS S X="",RACNT=0 "RTN","RAPTLU",22,0) ;I $$IMAGE^RARIC1 D MED^MAGSET3,ERASE^MAGSET3 ;don't call MAG 111300 "RTN","RAPTLU",23,0) S X="" "RTN","RAPTLU",24,0) F RADTI=0:0 Q:X="^"!(X>0) S RADTI=$O(^RADPT(RADFN,"DT",RADTI)) Q:RADTI'>0 I $D(^(RADTI,0)) S RANODE=^(0),RADTE=+^(0) D SEL2 ;swm080398 "RTN","RAPTLU",25,0) Q:X="^"!(X>0) I 'RACNT W !?3,$C(7),"No matches found!" Q "RTN","RAPTLU",26,0) ;**Next line commented out - was causing selection screen to disappear "RTN","RAPTLU",27,0) ; and automatically go on to detailed screen if there was only one "RTN","RAPTLU",28,0) ; case for the patient "RTN","RAPTLU",29,0) D ASK^RAUTL4 S:X="" X="^" "RTN","RAPTLU",30,0) Q "RTN","RAPTLU",31,0) SEL2 ; per RACNLU, check loc access, need split For Loop,swm080398 "RTN","RAPTLU",32,0) S RADIV=+$P(RANODE,"^",3),RAIMAGE=+$P(RANODE,"^",2) "RTN","RAPTLU",33,0) S RADIV=+$G(^RA(79,RADIV,0)),RADIV=$P($G(^DIC(4,RADIV,0)),"^") "RTN","RAPTLU",34,0) S:RADIV']"" RADIV="Unknown" "RTN","RAPTLU",35,0) S RAIMAGE=$P($G(^RA(79.2,RAIMAGE,0)),"^") "RTN","RAPTLU",36,0) S:RAIMAGE']"" RAIMAGE="Unknown" "RTN","RAPTLU",37,0) I '$D(ORVP),($D(RANOSCRN)),('$D(RADUPSCN)) I $D(^TMP($J,"RA D-TYPE"))!($D(^TMP($J,"RA I-TYPE"))) Q:'$D(^TMP($J,"RA D-TYPE",RADIV))!('$D(^TMP($J,"RA I-TYPE",RAIMAGE))) ;this stmt taken from RACNLU "RTN","RAPTLU",38,0) ; continue, since user has loc access "RTN","RAPTLU",39,0) F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:RACNI'>0 I $D(^(RACNI,0)) S RACN=^(0) D PRT Q:X="^"!(X>0) "RTN","RAPTLU",40,0) Q "RTN","RAPTLU",41,0) PRT ; Screen only if entered through Rad/Nuc Med "RTN","RAPTLU",42,0) I '$D(ORVP),'$D(RANOSCRN),'$D(RAOPT("DOSAGE TICKET")),'$D(RAOPT("UNCORRECTED REPORTS")) Q:$$IMGTY^RAUTL12("e",RADFN,RADTI)'=RAIMGTY "RTN","RAPTLU",43,0) ; "Duplicate Dosage Ticket" option has its own screen "RTN","RAPTLU",44,0) I $D(RAOPT("DOSAGE TICKET")) Q:$P($G(^RA(79.2,+$P(^RADPT(RADFN,"DT",RADTI,0),U,2),0)),U,5)'="Y" "RTN","RAPTLU",45,0) S RARPT=+$P(RACN,"^",17) "RTN","RAPTLU",46,0) Q:$D(RAOPT("UNCORRECTED REPORTS"))&('$O(^RARPT(RARPT,"ERR",0))) "RTN","RAPTLU",47,0) S RAST=+$P(RACN,"^",3),RAPRC=$S($D(^RAMIS(71,+$P(RACN,"^",2),0)):$P(^(0),"^"),1:"Unknown"),RACN=+RACN S (RADTPRT,Y)=RADTE D D^RAUTL S RADATE=Y "RTN","RAPTLU",48,0) S RAELOC=$P($G(^SC(+$P($G(^RA(79.1,+$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,4),0)),U),0)),U),RADTPRT=$E(RADTPRT,4,5)_"/"_$E(RADTPRT,6,7)_"/"_$E(RADTPRT,2,3) "RTN","RAPTLU",49,0) S:RAELOC="" RAELOC="* MISSING *" "RTN","RAPTLU",50,0) S RACNT=RACNT+1,^TMP($J,"RAEX",RACNT)=RADFN_"^"_RADTI_"^"_RACNI_"^"_RANME_"^"_RASSN_"^"_RADATE_"^"_RADTE_"^"_RACN_"^"_RAPRC_"^"_RARPT_"^"_RAST "RTN","RAPTLU",51,0) I $D(RAREPORT) D "RTN","RAPTLU",52,0) . S RAIMGTYI=$$IMGTY^RAUTL12("e",RADFN,RADTI) "RTN","RAPTLU",53,0) . S RASTP=$E($$GET1^DIQ(74,+RARPT,5),1,16) ;get all possible Rpt Statuss "RTN","RAPTLU",54,0) . I RASTP="",RAIMGTYI'="" S RASTP=RASTP_$S($D(^RA(72,"AA",RAIMGTYI,0,+RAST)):" (Exam Dc'd)",1:"") "RTN","RAPTLU",55,0) . Q "RTN","RAPTLU",56,0) I '$D(RAREPORT) S RASTP=$S($D(^RA(72,RAST,0)):$P(^(0),"^"),1:"Unknown") "RTN","RAPTLU",57,0) ; D:$$IMAGE^RARIC1 DISPA^MAGRIC ;don't call MAG 111300 "RTN","RAPTLU",58,0) N RAPRTSET,RAMEMLOW D EN1^RAUTL20 "RTN","RAPTLU",59,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RAPTLU",60,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN) "RTN","RAPTLU",61,0) ; "RTN","RAPTLU",62,0) D HD "RTN","RAPTLU",63,0) I $$USESSAN^RAHLRU1() W !,RACNT,?3,$S(RAMEMLOW:"+",RAPRTSET:".",1:" "),?4,RACNDSP,?19,$$IMGDISP(RARPT),?21,$E(RAPRC,1,26),?49,RADTPRT,?59,$E(RASTP,1,8),?68,$E(RAELOC,1,12) "RTN","RAPTLU",64,0) I '$$USESSAN^RAHLRU1() W !,RACNT,?5,$S(RAMEMLOW:"+",RAPRTSET:".",1:" "),?6,RACN,?11,$$IMGDISP(RARPT),?13,$E(RAPRC,1,26),?41,RADTPRT,?52,$E(RASTP,1,16),?69,$E(RAELOC,1,11) "RTN","RAPTLU",65,0) I (($Y+6)>IOSL),($O(^RADPT(RADFN,"DT",RADTI,"P",RACNI))!($O(^RADPT(RADFN,"DT",RADTI)))) D ASK^RAUTL4 W @IOF "RTN","RAPTLU",66,0) Q "RTN","RAPTLU",67,0) ; "RTN","RAPTLU",68,0) HD ; "RTN","RAPTLU",69,0) Q:RAHDCNT>0 "RTN","RAPTLU",70,0) S RAHDCNT=1 "RTN","RAPTLU",71,0) I '$D(RTFL) W @IOF,?25,RAHEAD,!!,"Patient's Name: ",$E(RANME,1,20)," ",RASSN,?55,"Run Date: " S Y=DT D DT^DIO2 "RTN","RAPTLU",72,0) I $D(RTFL) D ESC^RTRD:($Y+6)>IOSL Q:$D(RTESC) W !!,"============================ Exam Procedure Profile ==========================" "RTN","RAPTLU",73,0) I $$USESSAN^RAHLRU1() W !!?3,"Case No.",?21,"Procedure",?49,"Exam Dt",?59 W $S($D(RAREPORT):"Rpt",1:"Exam")," St",?68,"Imaging Loc" "RTN","RAPTLU",74,0) I $$USESSAN^RAHLRU1() W !?3,"--------",?21,"-------------",?49,"---------",?59,"--------",?68,"-----------" Q "RTN","RAPTLU",75,0) I '$$USESSAN^RAHLRU1() W !!?3,"Case No.",?13,"Procedure",?41,"Exam Date",?52,"Status of " W $S($D(RAREPORT):"Report",1:"Exam"),?69,"Imaging Loc" "RTN","RAPTLU",76,0) I '$$USESSAN^RAHLRU1() W !?3,"--------",?13,"-------------",?41,"---------",?52,"----------------",?69,"-----------" Q "RTN","RAPTLU",77,0) ; "RTN","RAPTLU",78,0) PTUPD ;Update Patient Info "RTN","RAPTLU",79,0) S DIC(0)="AEMQL" D ^RADPA K DIC,RAIC Q:Y<0 S DIE="^RADPT(",DA=+Y,DR=".04;1" D ^DIE "RTN","RAPTLU",80,0) PTUPD0 K DIR S DIR(0)="SOMA^Y:YES;N:NO;",DIR("A")="CONTRAST MEDIUM ALLERGY: " "RTN","RAPTLU",81,0) S ALLERGY=$$ORCHK^GMRAOR(DA,"CM") "RTN","RAPTLU",82,0) I ALLERGY]"" S DIR("B")=$S(ALLERGY=1:"YES",1:"NO") "RTN","RAPTLU",83,0) S DIR("?")="^D PTUPDH1^RAPTLU",DIR("??")="^D PTUPDH2^RAPTLU" "RTN","RAPTLU",84,0) D ^DIR K DIR I $D(DIRUT) G PTUPDX "RTN","RAPTLU",85,0) I ALLERGY'=$TR(Y,"YN","10") S X=0 D G:'X PTUPDX W " ??",$C(7) G PTUPD0 "RTN","RAPTLU",86,0) . I Y="N" S X=$$RACHK^GMRARAD(DA,Y) "RTN","RAPTLU",87,0) . I Y="Y" S X=($$RADD^GMRARAD(DA,"p",Y)'>0) "RTN","RAPTLU",88,0) . Q "RTN","RAPTLU",89,0) PTUPDX K %,%Y,ALLERGY,C,D,D0,DA,DE,DQ,DIE,DIR,DR,RAPTFL,DIC,X,Y "RTN","RAPTLU",90,0) Q "RTN","RAPTLU",91,0) PTUPDH1 W !?5,"If this patient has had an allergic reaction to contrast medium, enter 'Y'" "RTN","RAPTLU",92,0) W !?5,"for YES at this prompt. If not, enter 'N' for NO." "RTN","RAPTLU",93,0) D PTUPDH3 "RTN","RAPTLU",94,0) Q "RTN","RAPTLU",95,0) PTUPDH2 ; "RTN","RAPTLU",96,0) W !?5,"The value in this field is used to indicate if this Radiology" "RTN","RAPTLU",97,0) W !?5,"/Nuclear Medicine patient has had an allergic reaction to the contrast" "RTN","RAPTLU",98,0) W !?5,"medium during a Radiology/Nuclear Medicine procedure. It may contain a" "RTN","RAPTLU",99,0) W !?5,"'Y' for YES, or 'N' for NO. If YES, then a warning message is" "RTN","RAPTLU",100,0) W !?5,"displayed to the receptionist whenever this patient is" "RTN","RAPTLU",101,0) W !?5,"registered for a procedure that may involve contrast material." "RTN","RAPTLU",102,0) D PTUPDH3 "RTN","RAPTLU",103,0) Q "RTN","RAPTLU",104,0) PTUPDH3 W !?5,"CHOOSE FROM:" "RTN","RAPTLU",105,0) W !?5," Y YES" "RTN","RAPTLU",106,0) W !?5," N NO" "RTN","RAPTLU",107,0) Q "RTN","RAPTLU",108,0) IMGDISP(RARPT) ; Display "i" if an image is associated with the Rad/Nuc Med "RTN","RAPTLU",109,0) ; Report. Called from RAPROS - Exam Profile (Selected Sort) "RTN","RAPTLU",110,0) ; Input : RARPT - ien of the report "RTN","RAPTLU",111,0) ; Output: "i" if an image exists, else null ("") "RTN","RAPTLU",112,0) Q $S(+$O(^RARPT(RARPT,2005,0)):"i",1:"") "RTN","RAREG") 0^47^B43601921 "RTN","RAREG",1,0) RAREG ;HISC/GJC AISC/MJK,RMO-Register Rad/NM Patient ;8/15/97 11:04 "RTN","RAREG",2,0) ;;5.0;Radiology/Nuclear Medicine;**23,85,47**;Mar 16, 1998;Build 21 "RTN","RAREG",3,0) ; 06/07/2007 KAM/BAY RA*5*85 Remedy Call 185568 Exam Backdating "RTN","RAREG",4,0) K RADTE "RTN","RAREG",5,0) PAT D SET^RAPSET1 I $D(XQUIT) K XQUIT Q "RTN","RAREG",6,0) ; Is our sign-on location inactive? "RTN","RAREG",7,0) K DIR,DIROUT,DIRUT,DTOUT,DUOUT,RADIRYN,RAINATVE "RTN","RAREG",8,0) S RAINATVE=$$INLO^RAUTL13(+RAMLC) "RTN","RAREG",9,0) I RAINATVE D I $D(XQUIT)!(RADIRYN) K RADIRYN,RAINATVE Q "RTN","RAREG",10,0) . W !!?3,"Your current Imaging Location: '"_$P($G(RACCESS(DUZ,"LOC",+RAMLC)),U,2)_"' is inactive." "RTN","RAREG",11,0) . W !?3,"If you wish to register this patient for an exam, locations must be switched.",! "RTN","RAREG",12,0) . S DIR(0)="YA",DIR("B")="Yes" "RTN","RAREG",13,0) . S DIR("A")="Do you wish to switch locations at this time? " "RTN","RAREG",14,0) . S DIR("?")="Enter 'Y'es to switch locations, 'N'o to exit." "RTN","RAREG",15,0) . D ^DIR K DIR,DIROUT,DIRUT,DTOUT,DUOUT "RTN","RAREG",16,0) . S RADIRYN=$S('+Y:1,1:0) K X,Y Q:RADIRYN "RTN","RAREG",17,0) . W ! D KILL^RAPSET1,^RAPSET "RTN","RAREG",18,0) . I $D(XQUIT) K RACCESS Q "RTN","RAREG",19,0) . Q "RTN","RAREG",20,0) K RADIRYN,RAINATVE "RTN","RAREG",21,0) D HOME^%ZIS K X S DIC(0)="AEMQZ"_$S('$D(RAVSTFLG):"L",1:"") D ^RADPA G Q:Y<0 S RADFN=+Y,RACAT=$S($P(Y(0),"^",4)']"":"OUTPATIENT",1:$P($P(^DD(70,.04,0),$P(Y(0),"^",4)_":",2),";")) S:'$D(RAVSTFLG) RAREGFLG="" "RTN","RAREG",22,0) D ^RADEM2 G Q:RAPOP I $D(RAVSTFLG) S J=$O(^RADPT(RADFN,"DT",0)) G ADD1:$D(^(+J,0)) W !?3,*7,"A previous exam date does not exist for this patient!",! G Q "RTN","RAREG",23,0) DT K RADTEBAD N RAHRS S RAHRS=+$P($G(^RA(79,+RAMDIV,.1)),"^",24) ;How many hrs in adv? "RTN","RAREG",24,0) R !!,"Imaging Exam Date/Time: NOW// ",X:DTIME "RTN","RAREG",25,0) G Q:'$T!(X=" ")!(X="^") "RTN","RAREG",26,0) S:X="" RANOW="",X="NOW" "RTN","RAREG",27,0) S %DT(0)=-$$FMADD^XLFDT($$NOW^XLFDT,0,RAHRS,0,0),%DT="ETXR" "RTN","RAREG",28,0) D ^%DT K %DT G DT:Y<0 "RTN","RAREG",29,0) ; "RTN","RAREG",30,0) ; 06/06/2007 KAM/BAY Remedy Call 185568 Added next line "RTN","RAREG",31,0) I '$$BACKDATE(Y) G DT "RTN","RAREG",32,0) ; "RTN","RAREG",33,0) DT1 S RADTE=Y,RADTI=9999999.9999-RADTE "RTN","RAREG",34,0) I '$D(RAVSTFLG),$D(^RADPT(RADFN,"DT",RADTI,0)) D G DT "RTN","RAREG",35,0) . W !,*7,"Patient already has exams (which may have been cancelled) for this date/time." "RTN","RAREG",36,0) . W !,"....use 'Add Exams to Last Visit' option, or enter a date/time a few minutes",!," earlier or later." "RTN","RAREG",37,0) . Q "RTN","RAREG",38,0) ;Next line checks for case where exam date entered is a 'subset' of an "RTN","RAREG",39,0) ;existing exam date (i.e. 10:00 is a subset of 11:00 because DIC lookup "RTN","RAREG",40,0) ;drops trailing zeros - this was causing users to hang ;CH 4/19/94 "RTN","RAREG",41,0) S RADTEBAD=$O(^RADPT(RADFN,"DT","B",RADTE)) I RADTEBAD[RADTE W *7,!,"?? Please try a different time of day (a few minutes later)." G DT "RTN","RAREG",42,0) ;next line is a lock to prevent multiple users from adding/overwriting "RTN","RAREG",43,0) ;the same "DT" node if they begin registration of a case for the same "RTN","RAREG",44,0) ;patient during the same minute using NOW as the exam date/time. "RTN","RAREG",45,0) L +^RADPT(RADFN,"DT",RADTI):1 I '$T W !,*7,"Someone else is now editing an exam for this patient on the date/time",!,"you selected. Please try entering a date/time a few minutes earlier or later." G DT "RTN","RAREG",46,0) K RADTEBAD I $D(RANOW),$D(RAWARD) S RACAT="INPATIENT" "RTN","RAREG",47,0) I '$D(RANOW) K RAWARD,RABED,RASER D ^RASERV S:$D(RAWARD) RACAT="INPATIENT" "RTN","RAREG",48,0) G ^RAREG1 "RTN","RAREG",49,0) ; "RTN","RAREG",50,0) ADD S RAVSTFLG="" G PAT "RTN","RAREG",51,0) ADD1 S YY=^RADPT(RADFN,"DT",J,0) "RTN","RAREG",52,0) I $P(YY,"^",4)'=+RAMLC D G Q "RTN","RAREG",53,0) . W !!?3,"Last visit date is for location '",$S('$D(^RA(79.1,+$P(YY,"^",4),0)):"Unknown",$D(^SC(+^(0),0)):$P(^(0),"^"),1:"Unknown"),"'." "RTN","RAREG",54,0) . W !?3,"Your current location is defined as: '" "RTN","RAREG",55,0) . W $P($G(^SC(+$P($G(^RA(79.1,+RAMLC,0)),"^"),0)),"^")_"'." "RTN","RAREG",56,0) . W !?3,"You must log into the '" "RTN","RAREG",57,0) . W $S('$D(^RA(79.1,+$P(YY,"^",4),0)):"Unknown",$D(^SC(+^(0),0)):$P(^(0),"^"),1:"Unknown"),"' location" "RTN","RAREG",58,0) . W !?3,"to add exams to the last visit.",$C(7) "RTN","RAREG",59,0) . K DIR S DIR(0)="E" D ^DIR K DIR Q "RTN","RAREG",60,0) S X1=DT,X2=-1 D C^%DTC I X>+YY,'$D(^XUSEC("RA MGR",DUZ)) W !!?3,*7,"Last visit was before yesterday. No adding exams allowed!" G Q "RTN","RAREG",61,0) I $$USESSAN^RAHLRU1() W !!,"Last Visit Date/Time: " S Y=$P(YY,"^") D D^RAUTL W Y,!!?1,"Case No.",?18,"Procedure",?50,"Status",!?1,"----------------",?18,"---------",?50,"------" "RTN","RAREG",62,0) I '$$USESSAN^RAHLRU1() W !!,"Last Visit Date/Time: " S Y=$P(YY,"^") D D^RAUTL W Y,!!?1,"Case No.",?10,"Procedure",?42,"Status",!?1,"--------",?10,"---------",?42,"------" "RTN","RAREG",63,0) N RA0,RA17,RA1 S RA1=0 ;1=valid rpt, 0=stub/no rpt "RTN","RAREG",64,0) F I=0:0 S I=$O(^RADPT(RADFN,"DT",J,"P",I)) Q:I'>0 I $D(^(I,0)) S Y=^(0) D ADD2 "RTN","RAREG",65,0) I $P(YY,U,5),RA1 S Y=1 D Q "RTN","RAREG",66,0) . I $Y>(IOSL-6) N DIR S DIR(0)="E" D ^DIR Q:Y'>0 "RTN","RAREG",67,0) . W !!?2,"NOTE: Because all the cases within this exam date/time are" "RTN","RAREG",68,0) . W !?8,"part of one order set, and a valid report has been filed" "RTN","RAREG",69,0) . W !?8,"already, additional procedures may not be added to this visit." "RTN","RAREG",70,0) . W !?8,"You must register the desired exam(s) at a later date/time." "RTN","RAREG",71,0) . N Y R !!?2,"Press RETURN to continue:",Y:DTIME "RTN","RAREG",72,0) . Q "RTN","RAREG",73,0) S RARD("A")="Do you wish to add exams to this visit? ",RARD(1)="Yes^add exams to this visit",RARD(2)="No^stop",RARD("B")=2,RARD(0)="S" D SET^RARD K RARD G Q:$E(X)'="Y" "RTN","RAREG",74,0) S RAREC="",Y=$P(YY,"^") G DT1 "RTN","RAREG",75,0) ADD2 ; "RTN","RAREG",76,0) N RASSAN,RACNDSP S RASSAN=$P(Y,"^",31) "RTN","RAREG",77,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:$P(Y,"^")) "RTN","RAREG",78,0) I $$USESSAN^RAHLRU1() W !?1,RACNDSP,?18,$E($S($D(^RAMIS(71,+$P(Y,"^",2),0)):$P(^(0),"^"),1:"Unknown"),1,30),?50,$S($D(^RA(72,+$P(Y,"^",3),0)):$P(^(0),"^"),1:"Unknown") "RTN","RAREG",79,0) I '$$USESSAN^RAHLRU1() W !?3,$P(Y,"^"),?10,$E($S($D(^RAMIS(71,+$P(Y,"^",2),0)):$P(^(0),"^"),1:"Unknown"),1,30),?42,$S($D(^RA(72,+$P(Y,"^",3),0)):$P(^(0),"^"),1:"Unknown") "RTN","RAREG",80,0) K RAVLEDTI,RAVLECNI,RASHA,RARSH,RAPIFN,RARDTE,RALIFN S RAVLEDTI=J,RAVLECNI=I,RADIV=$P(YY,"^",3),RACAT=$S('$D(RAWARD):$P($P(^DD(75.1,4,0),$P(Y,"^",4)_":",2),";"),1:RACAT) "RTN","RAREG",81,0) S:"CS"[$E(RACAT)&($D(^DIC(34,+$P(Y,"^",9),0))) RASHA=$P(^(0),"^") S:"R"[$E(RACAT)&($D(^RADPT(RADFN,"DT",J,"P",I,"R"))) RARSH=^("R") "RTN","RAREG",82,0) S:$D(^VA(200,+$P(Y,"^",14),0)) RAPIFN=+$P(Y,"^",14) S:$P(Y,"^",21) RARDTE=$P(Y,"^",21) S:$D(^SC(+$P(Y,"^",22),0)) RALIFN=+$P(Y,"^",22) "RTN","RAREG",83,0) I $P(Y,"^",17)]"" D ; is this a non-stub report "RTN","RAREG",84,0) . S RA17=+$P(Y,"^",17) ;keep RA17 only if image stub rpt exists "RTN","RAREG",85,0) . I '$D(^RARPT(RA17,0))#2 K RA17 Q ; no rpt "RTN","RAREG",86,0) . Q:$$STUB^RAEDCN1(RA17) ;quit if image stub rpt "RTN","RAREG",87,0) . S RA1=1 K RA17 ; valid (non-stub record) "RTN","RAREG",88,0) Q "RTN","RAREG",89,0) ; "RTN","RAREG",90,0) Q K %,%DT,DA,DIC,GMRAL,POP,RABED,RACAT,RADFN,RADIV,RADTE,RADTI,RALIFN,RANME,RAOIFN,RAPIFN,RAPOP,RAPTFL,RARDTE,RAREGFLG,RARSH,RASER,RASEX,RASHA,RAVLECNI,RAVLEDTI,RAVSTFLG,RAWARD,X,XQUIT,Y,YY "RTN","RAREG",91,0) K %W,%X,%Y,%Y1,D,D3,DDER,DDH,DFN,DI,DIG,DIH,DIU,DIW,DIWF,DIWI,DIWL,DIWR "RTN","RAREG",92,0) K DIWT,DIWTC,DIWX,DN,I,RACANC,RACN0,RACPT,RACPTNDE,RAEXIT,RAHSMULT,RAI "RTN","RAREG",93,0) K RAN,RAOBR4,RAPARENT,RAPRCNDE,RAPROC,RAPROCI,RAPROCIT,RAPRV,RASKIPIT "RTN","RAREG",94,0) K VA,VADM,VAERR,Z "RTN","RAREG",95,0) Q "RTN","RAREG",96,0) ;06/06/2007 KAM/BAY for Remedy Call 185568 Added next 11 lines "RTN","RAREG",97,0) BACKDATE(RADT) ; "RTN","RAREG",98,0) N RACON,RAEXMDAT,RATODAY,RAANS,Y "RTN","RAREG",99,0) S RACON=1 "RTN","RAREG",100,0) S X="NOW" D ^%DT S RATODAY=Y K %DT "RTN","RAREG",101,0) I (RATODAY-RADT)>9999 D "RTN","RAREG",102,0) . W !!,"********************************************************" "RTN","RAREG",103,0) . W !,"The Exam date entered is more than one year in the past." "RTN","RAREG",104,0) . W !,"********************************************************" "RTN","RAREG",105,0) . R !!,"Are you sure you want to continue Y/N?: N// ",RAANS:DTIME "RTN","RAREG",106,0) . I "Y,y,YES,yes,Yes"'[RAANS!(RAANS="") S RACON=0 "RTN","RAREG",107,0) Q RACON "RTN","RARIC") 0^75^B25901329 "RTN","RARIC",1,0) RARIC ;HISC/FPT,GJC AISC/SAW-Radiologic Image Capture and Display Routine ;08/05/08 14:35 "RTN","RARIC",2,0) ;;5.0;Radiology/Nuclear Medicine;**23,27,101,47**;Mar 16, 1998;Build 21 "RTN","RARIC",3,0) ; "RTN","RARIC",4,0) ;In response to: Remedy #330689 (Tucson); PSPO 1460 "RTN","RARIC",5,0) ; "RTN","RARIC",6,0) ;Supported IA #2053 FILE/UPDATE^DIE "RTN","RARIC",7,0) ;Supported IA #2054 LOCK^DILF "RTN","RARIC",8,0) ;Supported IA #10103 $$NOW^XLFDT "RTN","RARIC",9,0) ; "RTN","RARIC",10,0) CREATE ; >>create new stub entry in file 74<< "RTN","RARIC",11,0) ; -------------------------------------------------------------------- "RTN","RARIC",12,0) ; IA: 1178 (the value of RARPT is currently null) If no report entry is "RTN","RARIC",13,0) ; created, RARPT is set to null or negative (negative w/report) "RTN","RARIC",14,0) ; "RTN","RARIC",15,0) ;input variables "RTN","RARIC",16,0) ; RADTE - ext. date/time of exam, RADFN - patient DFN, "RTN","RARIC",17,0) ; RADTI - int. date/time of exam), RACN - case number & "RTN","RARIC",18,0) ; RACNI - IEN of case record "RTN","RARIC",19,0) ; RATIMEOUT - An integer representing the number of seconds "RTN","RARIC",20,0) ; in which the process attempts to gain access "RTN","RARIC",21,0) ; to the node in question. RATIMEOUT is set ONLY "RTN","RARIC",22,0) ; on the Imaging Gateway side. All other applications "RTN","RARIC",23,0) ; calling the CREATE entry point will not have "RTN","RARIC",24,0) ; RATIMEOUT set and will use a default timeout "RTN","RARIC",25,0) ; value set at 1E9. "RTN","RARIC",26,0) ; "RTN","RARIC",27,0) ; Note: Imaging (Gateway) sets and kills RATIMEOUT. "RTN","RARIC",28,0) ; "RTN","RARIC",29,0) ;output variables "RTN","RARIC",30,0) ; RARPT - IEN of the report: null if error; or positive "RTN","RARIC",31,0) ; "RTN","RARIC",32,0) ; lock the exam node; quit if the lock fails "RTN","RARIC",33,0) S RARPT="" S U=$G(U,"^") "RTN","RARIC",34,0) L +^RADPT(RADFN,"DT",RADTI,"P",RACNI,0):$G(RATIMEOUT,1E9) E S RARPT="-1^radiology exam locked" Q "RTN","RARIC",35,0) ; "RTN","RARIC",36,0) ; Set RAY2 to the REGISTERED EXAMS node. "RTN","RARIC",37,0) ; Set RAY3 to the EXAMINATIONS node. "RTN","RARIC",38,0) N RAY2,RAY3 S RAY2=$G(^RADPT(RADFN,"DT",RADTI,0)) "RTN","RARIC",39,0) S RAY3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) "RTN","RARIC",40,0) ; "RTN","RARIC",41,0) ; "RTN","RARIC",42,0) ; 1 - If the Imaging value of the case number does not match "RTN","RARIC",43,0) ; the case number on disk quit. 2 - Quit if the exam was purged. "RTN","RARIC",44,0) ; ================================================================= "RTN","RARIC",45,0) I $P(RAY3,U)'=RACN D UNLOCXAM Q ; - 1 "RTN","RARIC",46,0) I $P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PURGE")),U)>0 D UNLOCXAM Q ; - 2 "RTN","RARIC",47,0) ; "RTN","RARIC",48,0) ; "RTN","RARIC",49,0) ; If a report was created for this case while waiting "RTN","RARIC",50,0) ; to access the exam node (timeout) set RARPT, unlock "RTN","RARIC",51,0) ; the exam node & exit (XIT). "RTN","RARIC",52,0) ; ================================================================= "RTN","RARIC",53,0) S RARPT=$P(RAY3,U,17) "RTN","RARIC",54,0) I RARPT D UNLOCXAM Q "RTN","RARIC",55,0) ; "RTN","RARIC",56,0) ; "RTN","RARIC",57,0) ; Create the accession number. The format may be that "RTN","RARIC",58,0) ; of the legacy accession or it may be (w/p47) a site "RTN","RARIC",59,0) ; specific accession (SSAN). Check if patch RA*5.0*47 "RTN","RARIC",60,0) ; has been installed. "RTN","RARIC",61,0) ; "RTN","RARIC",62,0) ; Because we entered the Radiology application through "RTN","RARIC",63,0) ; a foreign source the following package wide Radiology "RTN","RARIC",64,0) ; variables must be defined: RAMDIV & RAMDV "RTN","RARIC",65,0) ; ================================================================= "RTN","RARIC",66,0) N RACESION,RAMDIV,RAMDV "RTN","RARIC",67,0) S RAMDIV=+$P(RAY2,U,3),RAMDV=$S($D(^RA(79,RAMDIV,.1)):^(.1),1:"") "RTN","RARIC",68,0) I $P(RAY3,U,31)'="" D ; use SSAN "RTN","RARIC",69,0) .S RACESION=$P(RAY3,U,31) "RTN","RARIC",70,0) .Q "RTN","RARIC",71,0) ; else use the legacy accession "RTN","RARIC",72,0) E S RACESION=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN "RTN","RARIC",73,0) ; "RTN","RARIC",74,0) ; "RTN","RARIC",75,0) N RA1,RAERR,RAFDA,RAFDAIEN,RAIEN,RAPRTSET,RAMEMARR,RATXT,RAX,RAXIT,RAY "RTN","RARIC",76,0) ; "RTN","RARIC",77,0) ; Check if this case is part of a print set. "RTN","RARIC",78,0) ; ================================================================= "RTN","RARIC",79,0) ; D EN2^RAUTL20(.RAMEMARR) is a silent call! "RTN","RARIC",80,0) ; RAMEMARR = # of descendents "RTN","RARIC",81,0) ; RAMEMARR(n)=case #^procedure IEN^report text IEN^exam status IEN "RTN","RARIC",82,0) ; (where 'n' is RACNI) "RTN","RARIC",83,0) ; If printset RAPRTSET=1, else RAPRTSET=0 "RTN","RARIC",84,0) D EN2^RAUTL20(.RAMEMARR) ; is this case part of a print set ? "RTN","RARIC",85,0) ; "RTN","RARIC",86,0) ; "RTN","RARIC",87,0) ; Find the next available RAD/NUC MED REPORTS IEN, lock that record "RTN","RARIC",88,0) ; & file the report specific data into that new report record. "RTN","RARIC",89,0) ; ================================================================= "RTN","RARIC",90,0) S RAFDAIEN(1)=$$NEWIEN() "RTN","RARIC",91,0) ; "RTN","RARIC",92,0) ; ** Note: ^RARPT(RAFDAIEN(1)) is locked; it is up to ** "RTN","RARIC",93,0) ; ** YOU to unlock the record before the process quits ** "RTN","RARIC",94,0) ; "RTN","RARIC",95,0) S RAY="+1",RAX="RAFDA(74,"""_RAY_","")" "RTN","RARIC",96,0) S @RAX@(.01)=RACESION "RTN","RARIC",97,0) S @RAX@(2)=RADFN "RTN","RARIC",98,0) S @RAX@(3)=(9999999.9999-RADTI) "RTN","RARIC",99,0) S @RAX@(4)=RACN "RTN","RARIC",100,0) S @RAX@(6)=DT "RTN","RARIC",101,0) ; "RTN","RARIC",102,0) ;The filing of report text is no longer required. "RTN","RARIC",103,0) ;K RATXT("RPT") S RATXT("RPT",1)="Images collected." "RTN","RARIC",104,0) ;S @RAX@(200)="RATXT(""RPT"")" "RTN","RARIC",105,0) ; "RTN","RARIC",106,0) ; Create the Activity Log (74.01) sub-file record. "RTN","RARIC",107,0) S RAX="RAFDA(74.01,""+2,"_RAY_","")" "RTN","RARIC",108,0) S @RAX@(.01)=$$NOW^XLFDT() "RTN","RARIC",109,0) S @RAX@(2)=$S($D(RAESIG)#2:"V",1:"C") "RTN","RARIC",110,0) S @RAX@(3)=$S($G(RAVERF):RAVERF,1:DUZ) "RTN","RARIC",111,0) D UPDATE^DIE("","RAFDA","RAFDAIEN","RAERR") "RTN","RARIC",112,0) ; "RTN","RARIC",113,0) ; "RTN","RARIC",114,0) ; If there happened to be an error when calling UPDATE^DIE "RTN","RARIC",115,0) ; kill off the stub report record. "RTN","RARIC",116,0) ; ================================================================= "RTN","RARIC",117,0) I $D(RAERR("DIERR"))#2,($D(^RARPT(RAFDAIEN(1),0))#2) D D XIT Q "RTN","RARIC",118,0) .D DELRPT(RAFDAIEN(1)) ;note: RARPT is null "RTN","RARIC",119,0) .QUIT "RTN","RARIC",120,0) ; "RTN","RARIC",121,0) ; "RTN","RARIC",122,0) ; "RTN","RARIC",123,0) ; ** 70.03 - set report text field in the EXAMINATIONS node - 70.03 ** "RTN","RARIC",124,0) ; ** 70.03 - locked at the top of RARIC - 70.03 ** "RTN","RARIC",125,0) ; ================================================================= "RTN","RARIC",126,0) K RAERR,RAFDA,RAIEN,RATXT "RTN","RARIC",127,0) ; "RTN","RARIC",128,0) S RAIEN=RACNI_","_RADTI_","_RADFN_"," "RTN","RARIC",129,0) S RAFDA(70.03,RAIEN,17)=RAFDAIEN(1) "RTN","RARIC",130,0) D FILE^DIE("","RAFDA","RAERR") "RTN","RARIC",131,0) ; "RTN","RARIC",132,0) ; the REPORT TEXT field was not set correctly "RTN","RARIC",133,0) I $D(RAERR("DIERR"))#2 D DELRPT(RAFDAIEN(1)) D XIT Q "RTN","RARIC",134,0) ; "RTN","RARIC",135,0) ; "RTN","RARIC",136,0) ;the report record has been created, set RARPT = RAFDAIEN(1) "RTN","RARIC",137,0) S RARPT=RAFDAIEN(1) "RTN","RARIC",138,0) ; "RTN","RARIC",139,0) ; "RTN","RARIC",140,0) ; create a var RARIC to suppress display of info msg from PTR^RARTE2 "RTN","RARIC",141,0) ; PTR^RARTE2 requires that RARPT the IEN of an existing report record. "RTN","RARIC",142,0) ; ================================================================= "RTN","RARIC",143,0) N RARPTN S RARPTN=$P(^RARPT(RARPT,0),U) "RTN","RARIC",144,0) I RAPRTSET N RARIC S RARIC=1 D PTR^RARTE2 "RTN","RARIC",145,0) ; don't have to check raxit, since we're quitting now "RTN","RARIC",146,0) ; "RTN","RARIC",147,0) ; "RTN","RARIC",148,0) XIT ;exit the CREATE subroutine "RTN","RARIC",149,0) ; ================================================================= "RTN","RARIC",150,0) ;Unlock the case node & unlock the report. "RTN","RARIC",151,0) D UNLOCXAM L -^RARPT(RAFDAIEN(1)) "RTN","RARIC",152,0) QUIT "RTN","RARIC",153,0) ; "RTN","RARIC",154,0) ; "RTN","RARIC",155,0) PTR ; associate images with a radiology report record "RTN","RARIC",156,0) ; -------------------------------------------------------------------- "RTN","RARIC",157,0) ; "RTN","RARIC",158,0) ; input: RARPT - IEN of Rad/NM Report file #74 "RTN","RARIC",159,0) ; MAGGP - IEN of record in file 2005 pointed to by a report "RTN","RARIC",160,0) ; "RTN","RARIC",161,0) ; returns: Y=0 - variable MAGGP does not exist "RTN","RARIC",162,0) ; Y=-1 - FileMan could not create an entry (may be -1 w/report) "RTN","RARIC",163,0) ; Y>0 - FileMan created an entry "RTN","RARIC",164,0) ; "RTN","RARIC",165,0) S Y=0 Q:$G(MAGGP)'>0 "RTN","RARIC",166,0) L +^RARPT(RARPT):$G(DILOCKTM,5) "RTN","RARIC",167,0) I '$T S Y="-1^radiology report locked" Q ;lock failed... "RTN","RARIC",168,0) N RAFDA,RAIEN,RARSLT "RTN","RARIC",169,0) S RAFDA(74.02005,"+1,"_RARPT_",",.01)=MAGGP "RTN","RARIC",170,0) D UPDATE^DIE(,"RAFDA","RAIEN","RARSLT") "RTN","RARIC",171,0) I $D(RARSLT("DIERR"))#2 D "RTN","RARIC",172,0) .S Y=-1 ;RAIEN(1) undef "RTN","RARIC",173,0) .QUIT "RTN","RARIC",174,0) E I RAIEN(1)>0 S Y=RAIEN(1) "RTN","RARIC",175,0) L -^RARPT(RARPT) "RTN","RARIC",176,0) QUIT "RTN","RARIC",177,0) ; "RTN","RARIC",178,0) ; "RTN","RARIC",179,0) DELRPT(Y) ; delete a report (RARIC). The report record should "RTN","RARIC",180,0) ;be locked by the software calling this function. "RTN","RARIC",181,0) ; -------------------------------------------------------------------- "RTN","RARIC",182,0) ; Input: Y = the IEN of the report record "RTN","RARIC",183,0) ; "RTN","RARIC",184,0) K RAERR,RAFDA S RAFDA(74,Y_",",.01)="@" "RTN","RARIC",185,0) D FILE^DIE("","RAFDA","RAERR") K RAERR,RAFDA "RTN","RARIC",186,0) Q "RTN","RARIC",187,0) ; "RTN","RARIC",188,0) ; "RTN","RARIC",189,0) NEWIEN() ; ##### ALLOCATES A NEW RECORD IN THE RAD/NUC MED REPORTS FILE "RTN","RARIC",190,0) ; (#74) AND LOCKS IT "RTN","RARIC",191,0) ; -------------------------------------------------------------------- "RTN","RARIC",192,0) ; Return Values "RTN","RARIC",193,0) ; ============= "RTN","RARIC",194,0) ; >0 IEN for the new record in the RAD/NUC MED REPORTS FILE (#74) "RTN","RARIC",195,0) ; "RTN","RARIC",196,0) ; Notes "RTN","RARIC",197,0) ; ===== "RTN","RARIC",198,0) ; "RTN","RARIC",199,0) ; The placeholder for the new record (^RARPT(IEN) node) is LOCKed "RTN","RARIC",200,0) ; by this function. It is responsibility of the caller to unlock the "RTN","RARIC",201,0) ; record after it is created or the record creation is canceled. "RTN","RARIC",202,0) ; "RTN","RARIC",203,0) N IEN,NEWIEN,NODE "RTN","RARIC",204,0) S NEWIEN=0 "RTN","RARIC",205,0) ;--- "RTN","RARIC",206,0) F D Q:NEWIEN "RTN","RARIC",207,0) . S IEN=$O(^RARPT(" "),-1)+1 "RTN","RARIC",208,0) . ;--- If the record already exists, skip it "RTN","RARIC",209,0) . S NODE=$NA(^RARPT(IEN)) Q:$D(@NODE) "RTN","RARIC",210,0) . ;--- Lock the placeholder in order to make sure that nobody "RTN","RARIC",211,0) . ;--- else is trying to allocate it at the same time. "RTN","RARIC",212,0) . D LOCK^DILF(NODE) E Q "RTN","RARIC",213,0) . ;--- Double check that the record has not been created after the "RTN","RARIC",214,0) . ;--- previous $D() check and the LOCK command (a race condition) "RTN","RARIC",215,0) . I $D(@NODE) L -@NODE Q "RTN","RARIC",216,0) . ;--- Success "RTN","RARIC",217,0) . S NEWIEN=IEN "RTN","RARIC",218,0) . Q "RTN","RARIC",219,0) ;--- "RTN","RARIC",220,0) Q NEWIEN "RTN","RARIC",221,0) ; "RTN","RARIC",222,0) ; "RTN","RARIC",223,0) UNLOCXAM ;Unlock the EXAMINATION node locked by this process. "RTN","RARIC",224,0) ; -------------------------------------------------------------------- "RTN","RARIC",225,0) L -^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) QUIT "RTN","RARIC",226,0) ; "RTN","RART1") 0^48^B63511305 "RTN","RART1",1,0) RART1 ;HISC/GJC,SWM-Reporting Menu (Part 2) ;05/13/09 08:05 "RTN","RART1",2,0) ;;5.0;Radiology/Nuclear Medicine;**8,16,15,21,23,27,34,99,47**;Mar 16, 1998;Build 21 "RTN","RART1",3,0) ;Print Report By Patient has been moved to 4^RART2! "RTN","RART1",4,0) ;these sections are moved to ^RART3 : QRPT, PHYS, MODSET, OUT1 "RTN","RART1",5,0) ;RVD P99, add pregnancy screen and commment if populated for female pt. "RTN","RART1",6,0) CHK I 'RARPT!('$D(^RARPT(+RARPT,0))) W !?3,$C(7),"No report filed for case number ",RACN,"." K RARPT Q "RTN","RART1",7,0) I $D(RADFT),$P(^RARPT(+RARPT,0),"^",5)'["D" W !?3,$C(7),"Report for case number ",RACN," is not in a 'draft' status." K RARPT Q "RTN","RART1",8,0) I '$D(RADFT),$P(^RARPT(+RARPT,0),"^",5)["D" W !?3,$C(7),"Report filed for case number ",RACN," but not available for printing." K RARPT Q "RTN","RART1",9,0) Q "RTN","RART1",10,0) ; "RTN","RART1",11,0) 5 ;;Draft Report (Reprint) "RTN","RART1",12,0) D SETVARS Q:'($D(RACCESS(DUZ))\10)!('$D(RAIMGTY)) S RADFT="" G 4^RART2 "RTN","RART1",13,0) ; "RTN","RART1",14,0) 6 ;;Display a Report By Patient "RTN","RART1",15,0) W ! S DIC(0)="AEMQ" D ^RADPA G Q6:Y<0 S RADFN=+Y,RAHEAD="**** Patient's Exams ****",RAF1=1,RAREPORT=1 D ^RAPTLU G Q6:X="^" G 6:'$D(RADUP) "RTN","RART1",16,0) I X=1 R X:3 "RTN","RART1",17,0) OERR ;entry from RA OERR PROFILE protocol "RTN","RART1",18,0) F RAI=0:0 S RAI=$O(RADUP(RAI)) Q:RAI'>0 S Y=^TMP($J,"RAEX",RAI) D 61,DISP Q:X="^" "RTN","RART1",19,0) K RADUP,RAI,RAJ,X,^TMP($J,"RAEX") Q:$D(ORVP) G 6 "RTN","RART1",20,0) 61 F RAJ=1:1:11 S @$P("RADFN^RADTI^RACNI^RANME^RASSN^RADATE^RADTE^RACN^RAPRC^RARPT^RAST","^",RAJ)=$P(Y,"^",RAJ) "RTN","RART1",21,0) S Y(0)=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) Q "RTN","RART1",22,0) ; "RTN","RART1",23,0) OERR1 ;Entry Point for Alert Follow-Up Action for OE/RR "RTN","RART1",24,0) Q:'$D(XQADATA)!('$D(XQAID)) S (RARPT,Y)=XQADATA D RASET^RAUTL2 "RTN","RART1",25,0) S:Y Y(0)=Y,RANME=$S($D(^DPT(RADFN,0)):$P(^(0),"^"),1:"Unknown"),RAPRC=$S($D(^RAMIS(71,+$P(Y(0),"^",2),0)):$P(^(0),"^"),1:"Unknown") "RTN","RART1",26,0) S RALERTS="" D DISP K:X="^" XQAID,XQAKILL "RTN","RART1",27,0) I $D(XQAID) S DFN=$P(XQAID,",",2) D DELETE^XQALERT "RTN","RART1",28,0) K RALERTS "RTN","RART1",29,0) Q "RTN","RART1",30,0) ; "RTN","RART1",31,0) DISP I RARPT,($D(RAPBRPT)),($P($G(^RARPT(+RARPT,0)),"^",5)="V") D Q "RTN","RART1",32,0) . ; This code will not allow a user to re-edit a verified report. "RTN","RART1",33,0) . ; In this case, two or more possible users signed on to the same "RTN","RART1",34,0) . ; Imaging location, asked to verify the reports of the same "RTN","RART1",35,0) . ; Interpreting Radiology/Nuclear Medicine Physician. "RTN","RART1",36,0) . ; For the 'On-line Verifying of Reports' option only! "RTN","RART1",37,0) . N DIR,DIROUT,DIRUT,DTOUT,DUOUT,Y "RTN","RART1",38,0) . ; removed X from N so rtn RARTVER would quit if caret entered "RTN","RART1",39,0) . W !!?10,"Since the time you selected this group of reports,",!?10,$P($G(^VA(200,+$P(^RARPT(+RARPT,0),"^",9),0)),U)," has verified the report for " "RTN","RART1",40,0) . W !?10,$P($G(^DPT(+$P(^RARPT(+RARPT,0),"^",2),0)),U)," case #",$P(^RARPT(+RARPT,0),"^"),".",$C(7) "RTN","RART1",41,0) . S Y=$S($D(^TMP($J,"RA","DT",+$G(RARTDT),+$G(RARPT))):$P($P(^(RARPT),"/",2),U,3),$D(RARPTX(+$G(RPTX))):$P($P(RARPTX(+$G(RPTX)),"/",2),U,3),1:"") "RTN","RART1",42,0) . I $D(^RAMIS(71,+Y,0)) W !?10,"Procedure ",$P(^(0),U) "RTN","RART1",43,0) . W ! K DIR S DIR(0)="E" D ^DIR S RAVFIED=1 "RTN","RART1",44,0) . Q "RTN","RART1",45,0) D HOME^%ZIS S OREND=1 "RTN","RART1",46,0) I 'RARPT!('$D(^RARPT(+RARPT,0))) D G Q6 "RTN","RART1",47,0) . W !?3,$C(7),"No report filed for case number",$S($D(RACN):" "_RACN,1:""),"." "RTN","RART1",48,0) . R X:3 ; D:$$IMAGE^RARIC1 DISPF^MAGRIC ;don't call MAG 111300 "RTN","RART1",49,0) . Q "RTN","RART1",50,0) S RAST=$P(^RARPT(+RARPT,0),"^",5) "RTN","RART1",51,0) I '$D(RARTVER),(RAST=""!(RAST["D")) D G Q6 "RTN","RART1",52,0) . W !?3,$C(7),"Report filed for case number ",RACN," but not available for display." "RTN","RART1",53,0) . R X:3 ; D:$$IMAGE^RARIC1 DISPF^MAGRIC ;don't call MAG 111300 "RTN","RART1",54,0) . Q "RTN","RART1",55,0) DISP1 I $S('$D(ORACTION):1,ORACTION'=8:1,'$D(X):0,X="T":1,1:0) W @IOF "RTN","RART1",56,0) W !,RANME," (",$$SSN^RAUTL,")",?39,"Case No. ",?55,": ",$P($G(^RARPT(RARPT,0)),"^")," @",$E(RADATE,$L(RADATE)-4,$L(RADATE)) "RTN","RART1",57,0) W !,$E(RAPRC,1,40) I +$G(^RARPT(RARPT,"T")) W ?39,"Transcriptionist",?55,": ",$E($P($G(^VA(200,+^RARPT(RARPT,"T"),0)),"^"),1,20) "RTN","RART1",58,0) N R3 S R3=$G(^RADPT(+$G(RADFN),"DT",+$G(RADTI),"P",+$G(RACNI),0)) "RTN","RART1",59,0) W !,"Req. Phys : ",$E($P($G(^VA(200,+$P(R3,"^",14),0)),"^"),1,25) "RTN","RART1",60,0) S RAPREVER=+$P($G(^RARPT(RARPT,0)),"^",13) W ?39,"Pre-verified",?55,": ",$S($D(^VA(200,RAPREVER,0)):$E($P($G(^VA(200,RAPREVER,0)),"^"),1,24),1:"NO") K RAPREVER "RTN","RART1",61,0) D PHYS^RART3 "RTN","RART1",62,0) ;Display Pregnancy Screen and Comments if respective field is filled and pt is female, patch #99 "RTN","RART1",63,0) I $$PTSEX^RAUTL8(RADFN)="F" D "RTN","RART1",64,0) .W:$P(R3,U,32)'="" !,"Pregnancy Screen: ",$S($P(R3,"^",32)="y":"Patient answered yes",$P(R3,"^",32)="n":"Patient answered no",$P(R3,"^",32)="u":"Patient is unable to answer or is unsure",1:"") "RTN","RART1",65,0) .N RAPCOMM S RAPCOMM=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCOMM")) "RTN","RART1",66,0) .W:$P(R3,U,32)'=""&$L(RAPCOMM) !,"Pregnancy Screen Comment: ",RAPCOMM "RTN","RART1",67,0) I $D(RAPBRPT),(RAST="PD") D "RTN","RART1",68,0) . W !,"**Prob Text: " "RTN","RART1",69,0) . I $G(^RARPT(+RARPT,"P"))]"" D "RTN","RART1",70,0) .. S X=$G(^RARPT(+RARPT,"P")) "RTN","RART1",71,0) .. D OUTTEXT^RAUTL9(X,"",10,70,13,"","!") "RTN","RART1",72,0) .. Q "RTN","RART1",73,0) . Q "RTN","RART1",74,0) W !,$$REPEAT^XLFSTR("=",79) "RTN","RART1",75,0) I $O(^RARPT(RARPT,1,0)) D MODSET^RART3 "RTN","RART1",76,0) I '$O(^RARPT(RARPT,1,0)) D "RTN","RART1",77,0) . D MODS^RAUTL2,OUT1^RART3 "RTN","RART1",78,0) . I +$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",28) S X=$$RDIO1^RARTUTL1(+$P(^(0),"^",28)) "RTN","RART1",79,0) . Q:$L($G(X)) ; 'X' should be 'null' to continue "RTN","RART1",80,0) . S:+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) X=$$PHARM1^RARTUTL(RACNI_","_RADTI_","_RADFN_",") "RTN","RART1",81,0) . Q "RTN","RART1",82,0) Q:$G(X)="P" G DISP1:$G(X)="T",Q6:$G(X)="^" "RTN","RART1",83,0) I +$O(^RARPT(RARPT,"ERR",0)) W !?10,$$AMENRPT^RARTR2(),! "RTN","RART1",84,0) ; "RTN","RART1",85,0) ; Print the clinical history from file 70 "RTN","RART1",86,0) I +$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",0)) D "RTN","RART1",87,0) . K ^UTILITY($J,"W"),^(1) S X="",DIWL=3,DIWF="|WC75" "RTN","RART1",88,0) . W !?3,"Clinical History:" "RTN","RART1",89,0) . S RAP="H" D WRITEHX(RAP) "RTN","RART1",90,0) . Q "RTN","RART1",91,0) Q:$G(X)="P" G DISP1:$G(X)="T",Q6:$G(X)="^" "RTN","RART1",92,0) ; "RTN","RART1",93,0) ; Print the additional report clinical history if defined and "RTN","RART1",94,0) ; different than the order clinical history. "RTN","RART1",95,0) I +$O(^RARPT(RARPT,"H",0)) D "RTN","RART1",96,0) . D CHKDUPHX Q:RADUPHX ; Duplicate history "RTN","RART1",97,0) . K ^UTILITY($J,"W"),^(1) S X="",DIWL=3,DIWF="|WC75" "RTN","RART1",98,0) . W !?3,"Additional Clinical History:" "RTN","RART1",99,0) . S RAP="AH" D WRITEHX(RAP) "RTN","RART1",100,0) ; "RTN","RART1",101,0) ; Print Report and Impression text "RTN","RART1",102,0) F RAP="R","I" D Q:X="^"!(X="P")!(X="T") "RTN","RART1",103,0) . K ^UTILITY($J,"W"),^(1) S X="",DIWL=3,DIWF="|WC75" "RTN","RART1",104,0) . W !?3,$S(RAP="R":"Report:",1:"Impression:") W:RAP="R" ?45,"Status: ",$$XTERNAL^RAUTL5(RAST,$P($G(^DD(74,5,0)),U,2)) "RTN","RART1",105,0) . W:RAP="R"&($E(RAST)="P") $C(7) "RTN","RART1",106,0) . D WRITE "RTN","RART1",107,0) . Q "RTN","RART1",108,0) Q:X="P" G DISP1:X="T",Q6:X="^" "RTN","RART1",109,0) ; I $$IMAGE^RARIC1() D DISPF^MAGRIC ;don't call MAG 111300 "RTN","RART1",110,0) I $P($G(^RA(79.1,+$P(^RADPT(RADFN,"DT",RADTI,0),U,4),0)),U,18)="Y" D PRTDX^RART K RADXCODE "RTN","RART1",111,0) Q:X="P" G DISP1:X="T",Q6:X="^" "RTN","RART1",112,0) ; "RTN","RART1",113,0) I $D(ORVP) D "RTN","RART1",114,0) .S RAVERF=+$P($G(^RARPT(+RARPT,0)),"^",9) "RTN","RART1",115,0) .S RADFTSBN=$E($P($G(^VA(200,RAVERF,20)),"^",2),1,25) "RTN","RART1",116,0) .S:RADFTSBN']"" RADFTSBN=$E($P($G(^VA(200,RAVERF,0)),"^"),1,25) "RTN","RART1",117,0) .S RADFTSBT=$E($P($G(^VA(200,RAVERF,20)),"^",3),1,30) "RTN","RART1",118,0) .S:RADFTSBT']"" RADFTSBT=$$TITLE^RARTR0(RAVERF) "RTN","RART1",119,0) .W !!,"VERIFIED BY:",!?2,$S(RADFTSBN]"":RADFTSBN,1:"") "RTN","RART1",120,0) .W:RADFTSBT]"" ", "_RADFTSBT "RTN","RART1",121,0) Q:X="P" G DISP1:X="T",Q6:X="^" "RTN","RART1",122,0) ; "RTN","RART1",123,0) K RAP I '$D(RARTVER) D WAIT Q:X="P" G DISP1:X="T" "RTN","RART1",124,0) Q6 K %,DIC,DIWF,DIWL,DIWR,I,J,OREND,POP,RABTCH,RAF1,RAHEAD,RALOC,RANME,RAPAR,RAPRC,RAREPORT,RASEL,RASSN,RAST,RAV,RAXX,Y,X1,Z "RTN","RART1",125,0) K RAVERF,RADFTSBN,RADFTSBT "RTN","RART1",126,0) K DIW,DIWT,DN "RTN","RART1",127,0) K C,DIPGM,DISYS,R1,RAIMGTYI,RAP "RTN","RART1",128,0) K:'$D(RARTVER) RACN,RACNI,RADATE,RADFN,RADTE,RADTI,RARPT Q "RTN","RART1",129,0) ; "RTN","RART1",130,0) WRITE K RAXX N Y "RTN","RART1",131,0) F RAV=0:0 S RAV=$O(^RARPT(RARPT,RAP,RAV)) Q:RAV'>0 D Q:X="^"!(X="P")!(X="T") "RTN","RART1",132,0) . S RAXX=^RARPT(RARPT,RAP,RAV,0) S X="" "RTN","RART1",133,0) . D WAIT:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="P")!(X="T") "RTN","RART1",134,0) . S X=RAXX D ^DIWP S X="" "RTN","RART1",135,0) . Q "RTN","RART1",136,0) Q:X="^" D ^DIWW:$D(RAXX) Q "RTN","RART1",137,0) ; "RTN","RART1",138,0) WRITEHX(RAP) ; Get and write the clinical history "RTN","RART1",139,0) ; "RTN","RART1",140,0) ;Input: RAP H = Clinical History from file 70 "RTN","RART1",141,0) ; AH = Additional Clinical History from file 74 "RTN","RART1",142,0) ; "RTN","RART1",143,0) K RAXX N Y "RTN","RART1",144,0) S RAV=0 "RTN","RART1",145,0) I RAP="H" D "RTN","RART1",146,0) . F S RAV=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV)) Q:RAV'>0 D Q:X="^"!(X="P")!(X="T") "RTN","RART1",147,0) . . S RAXX=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAV,0),X="" "RTN","RART1",148,0) . . D WAIT:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="P")!(X="T") "RTN","RART1",149,0) . . S X=RAXX D ^DIWP S X="" "RTN","RART1",150,0) . . Q "RTN","RART1",151,0) I RAP="AH" D "RTN","RART1",152,0) . F S RAV=$O(^RARPT(RARPT,"H",RAV)) Q:RAV'>0 D Q:X="^"!(X="P")!(X="T") "RTN","RART1",153,0) . . S RAXX=^RARPT(RARPT,"H",RAV,0),X="" "RTN","RART1",154,0) . . D WAIT:($Y+6)>IOSL&('$D(RARTVERF)) Q:X="^"!(X="P")!(X="T") "RTN","RART1",155,0) . . S X=RAXX D ^DIWP S X="" "RTN","RART1",156,0) . . Q "RTN","RART1",157,0) Q:X="^" D ^DIWW:$D(RAXX) Q "RTN","RART1",158,0) ; "RTN","RART1",159,0) CHKDUPHX ; Check Duplicate History in file 70 and 74. "RTN","RART1",160,0) ; Returns RADUPHX 1 = Duplicate "RTN","RART1",161,0) ; 0 = Different "RTN","RART1",162,0) N RAX,RA74,RA70,RAOK,RAX1 "RTN","RART1",163,0) ; Initialize to Different "RTN","RART1",164,0) S RADUPHX=0 "RTN","RART1",165,0) ; Quit if H node does not exist. Could have been purged. "RTN","RART1",166,0) I '$D(^RARPT(RARPT,"H")) S RADUPHX=1 Q "RTN","RART1",167,0) S RA74=$O(^RARPT(RARPT,"H",""),-1) "RTN","RART1",168,0) S RA70=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",""),-1),RA701=$O(^(0)) "RTN","RART1",169,0) S RAX=RA74-RA70+1 Q:RAX'=1 ; begin comparison "RTN","RART1",170,0) ; Check line by line of each file "RTN","RART1",171,0) ; RAOK 1 = all lines match "RTN","RART1",172,0) ; 0 = at least 1 difference "RTN","RART1",173,0) S RAOK=1 "RTN","RART1",174,0) F RAX1=RA701:1:RA70 I ^RARPT(RARPT,"H",RAX1,0)'=^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",RAX1,0) S RAOK=0 Q ;can exit loop on 1st difference "RTN","RART1",175,0) I 'RAOK Q "RTN","RART1",176,0) S RADUPHX=1 "RTN","RART1",177,0) Q "RTN","RART1",178,0) ; "RTN","RART1",179,0) WAIT ; user input, goto top, print, or continue "RTN","RART1",180,0) S RARD(1)="Continue^continue normal processing" "RTN","RART1",181,0) S:$D(RALERTS) RARD(2)="Print^print the entire report" "RTN","RART1",182,0) S RARD(3)="Top^display the report from the beginning" "RTN","RART1",183,0) S (RARD("B"),RARD("DTOUT"))=1 "RTN","RART1",184,0) S:$D(RALERTS) RARD("A")="Enter 'Top', 'Print' or 'Continue': " "RTN","RART1",185,0) S:'$D(RALERTS) RARD("A")="Enter 'Top' or 'Continue': " "RTN","RART1",186,0) S RARD(0)="S" D SET^RARD K RARD S X=$E(X) "RTN","RART1",187,0) I $D(RALERTS),(X="P") D QRPT^RART3 "RTN","RART1",188,0) Q:X="^"!(X="P") W:X="C"&($D(RAP)) @IOF "RTN","RART1",189,0) Q "RTN","RART1",190,0) ; "RTN","RART1",191,0) LOCK(X,Y) ; Lock an entry "RTN","RART1",192,0) W !!,$C(7),"Another user is editing this ",$S(X="R":"report (Case # "_Y_")",1:"exam (diagnostic code)"),". Please try again later." H 4 Q "RTN","RART1",193,0) ; "RTN","RART1",194,0) SETVARS ; Setup Rad/Nuc Med required variables "RTN","RART1",195,0) I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) "RTN","RART1",196,0) Q:'($D(RACCESS(DUZ))\10) "RTN","RART1",197,0) I $G(RAIMGTY)="" D SETVARS^RAPSET1(1) "RTN","RART1",198,0) Q "RTN","RART2") 0^49^B9326949 "RTN","RART2",1,0) RART2 ;HISC/GJC-Reporting Menu (Part 3) ;4/3/97 08:33 "RTN","RART2",2,0) ;;5.0;Radiology/Nuclear Medicine;**26,47**;Mar 16, 1998;Build 21 "RTN","RART2",3,0) 4 ;;Print Report By Patient "RTN","RART2",4,0) K ^TMP($J,"RAEX") "RTN","RART2",5,0) S RAF1="" ; allow the user to select a range of case #'s "RTN","RART2",6,0) S DIC(0)="AEMQ" D ^RADPA "RTN","RART2",7,0) I Y<0 D Q4 Q "RTN","RART2",8,0) S RADFN=+Y,RAHEAD="**** Patient's Exams ****",RAREPORT=1 "RTN","RART2",9,0) D ^RAPTLU "RTN","RART2",10,0) I X="^" D Q4 Q "RTN","RART2",11,0) S RAGJC=0 F S RAGJC=$O(^TMP($J,"RAEX",RAGJC)) Q:RAGJC'>0 D "RTN","RART2",12,0) . I '$D(RADUP(RAGJC)) K ^TMP($J,"RAEX",RAGJC) Q "RTN","RART2",13,0) . D CHK(RAGJC) ; check all existing entries! "RTN","RART2",14,0) . Q "RTN","RART2",15,0) I '$D(^TMP($J,"RAEX")) D D Q4 Q ; quit if nothing to print "RTN","RART2",16,0) . W !?4,"There are no reports left to print!",$C(7) "RTN","RART2",17,0) . Q "RTN","RART2",18,0) K %ZIS,IOP W ! S %ZIS="QM",%ZIS("A")="Select a device: " "RTN","RART2",19,0) D ^%ZIS I POP D Q4 Q "RTN","RART2",20,0) I $D(IO("Q")) D D Q4 Q "RTN","RART2",21,0) . S ZTRTN="START^RART2",ZTSAVE("^TMP($J,""RAEX"",")="" "RTN","RART2",22,0) . S ZTDESC="Rad/Nuc Med Print Selected Reports By Patient" "RTN","RART2",23,0) . S:'$D(RADFT) ZTSAVE("RASTFL")="",RASTFL="" "RTN","RART2",24,0) . S:$D(RAOPT) ZTSAVE("RAOPT")="" "RTN","RART2",25,0) . D ^%ZTLOAD "RTN","RART2",26,0) . I +$G(ZTSK("D"))>0 W !?5,"Request Queued, Task #: ",$G(ZTSK) "RTN","RART2",27,0) . D HOME^%ZIS K IO("Q") ;restore home device parameters P26 "RTN","RART2",28,0) . Q "RTN","RART2",29,0) START ; start printing the data "RTN","RART2",30,0) U IO S RAGJC=0 ; RAOOUT is defined in RARTR if abnormal exit (eos) "RTN","RART2",31,0) F S RAGJC=$O(^TMP($J,"RAEX",RAGJC)) Q:RAGJC'>0 D Q:$D(RAOOUT) "RTN","RART2",32,0) . S RAXAM=$G(^TMP($J,"RAEX",RAGJC)) "RTN","RART2",33,0) . S RARPT=+$P(RAXAM,"^",10) D:RARPT PRT^RARTR "RTN","RART2",34,0) . Q "RTN","RART2",35,0) D CLOSE "RTN","RART2",36,0) Q "RTN","RART2",37,0) CLOSE ; Close the device "RTN","RART2",38,0) W ! D ^%ZISC "RTN","RART2",39,0) Q4 ; Kill & Quit "RTN","RART2",40,0) S:$D(ZTQUEUED) ZTREQ="@" "RTN","RART2",41,0) K %I,%W,%X,%XX,%Y,%YY,%ZHFN,%ZISZ,C,DFN,DIC,DIROUT,DIRUT,DIW,DIWF,DIWL "RTN","RART2",42,0) K DIWR,DIWT,DLAYGO,DTOUT,DUOUT,ER,RACATP,RACN,RACNI,RADATE,RADFN,RADFT "RTN","RART2",43,0) K RADOC,RADTE,RADTI,RADUP,RAF1,RAGJC,RAHEAD,RAI,RAMES,RANM,RANME,RANOW "RTN","RART2",44,0) K RANUM,RAOATP,RAOOUT,RAPAR,RAPOP,RAPRC,RAPTLOC,RAREDT,RAREPORT,RARPT "RTN","RART2",45,0) K RAS,RASEL,RASSN,RAST,RASTFL,RAXAM,X,X1,X2,XMAP0R,XMDISP1,XMGAPI1 "RTN","RART2",46,0) ;K XMLOC,XMN,XMREC,XQXFLG,XMXUSER,Y,ZTDESC,ZTRTN,ZTSAVE,ZTSK "RTN","RART2",47,0) K XMLOC,XMN,XMREC,XMXUSER,Y,ZTDESC,ZTRTN,ZTSAVE,ZTSK ;P47 "RTN","RART2",48,0) K ^TMP($J,"RAEX") "RTN","RART2",49,0) K DIPGM,I,POP,RAIMGTYI,RAVERFDT,RAWHOVER,RAPRTSET,DISYS "RTN","RART2",50,0) Q "RTN","RART2",51,0) CHK(X) ; check if a valid report "RTN","RART2",52,0) ; 'X' is the subscript on ^TMP($J,"RAEX") "RTN","RART2",53,0) N RACASE,RAXAM,Y S RAXAM=$G(^TMP($J,"RAEX",X)) "RTN","RART2",54,0) S RACASE=$P(RAXAM,"^",8),Y=$P(RAXAM,"^",10) "RTN","RART2",55,0) I '$L(Y)!('$D(^RARPT(+Y,0))) D Q "RTN","RART2",56,0) . W !?3,*7,"No report filed for case number ",RACASE,"." "RTN","RART2",57,0) . K ^TMP($J,"RAEX",X) "RTN","RART2",58,0) . Q "RTN","RART2",59,0) I $D(RADFT),$P(^RARPT(+Y,0),"^",5)'["D" D Q "RTN","RART2",60,0) . W !?3,"Report for case number ",RACASE," is not in a 'draft' status." "RTN","RART2",61,0) . W $C(7) K ^TMP($J,"RAEX",X) "RTN","RART2",62,0) . Q "RTN","RART2",63,0) I '$D(RADFT),$P(^RARPT(+Y,0),"^",5)["D" D Q "RTN","RART2",64,0) . W !?3,"Report filed for case number ",RACASE," but not available" "RTN","RART2",65,0) . W " for printing.",$C(7) "RTN","RART2",66,0) . K ^TMP($J,"RAEX",X) "RTN","RART2",67,0) . Q "RTN","RART2",68,0) Q "RTN","RARTE") 0^50^B44678185 "RTN","RARTE",1,0) RARTE ;HISC/FPT,GJC AISC/MJK,RMO-Edit/Delete Reports ;05/22/09 10:20 "RTN","RARTE",2,0) ;;5.0;Radiology/Nuclear Medicine;**18,34,45,56,99,47**;Mar 16, 1998;Build 21 "RTN","RARTE",3,0) ;Supported IA #3544 ^VA(200,"ARC" "RTN","RARTE",4,0) ;Supported IA #10076 ^XUSEC( "RTN","RARTE",5,0) ;Supported IA #2056 ^GET1^DIQ "RTN","RARTE",6,0) ;Supported IA #10009 YN^DICN "RTN","RARTE",7,0) ; last modification by SS for P18 June 14,2000 "RTN","RARTE",8,0) ; "RTN","RARTE",9,0) D SET^RAPSET1 I $D(XQUIT) K XQUIT Q "RTN","RARTE",10,0) W !!?3,"Note: To enter receipt of OUTSIDE INTERPRETED REPORTS,",!?3,"please use the 'Outside Report/Entry Edit' option.",! "RTN","RARTE",11,0) N RAXIT,RADRS,RASUBY0 S RAXIT=0 ;RADRS=copy (1=diag, 2=resid,staff) "RTN","RARTE",12,0) I $D(RANOSCRN) S X=$$DIVLOC^RAUTL7() I X D Q^RARTE4 QUIT "RTN","RARTE",13,0) ; "RTN","RARTE",14,0) ;1. DO NOT KILL the RASIG variable; the RASIG() array is needed in "RTN","RARTE",15,0) ; the edit template [RA REPORT EDIT] later "RTN","RARTE",16,0) ;2. The RAELESIG canNOT store file 74's ien, as no rpt has been picked "RTN","RARTE",17,0) ; from this call to ES^RASIGU "RTN","RARTE",18,0) ; "RTN","RARTE",19,0) I $D(^XUSEC("RA VERIFY",DUZ)),($$GET1^DIQ(200,DUZ_",",20.4)]""),($D(^VA(200,"ARC","R",DUZ))!($D(^VA(200,"ARC","S",DUZ)))) D Q:'$D(RAELESIG) "RTN","RARTE",20,0) . W ! D ES^RASIGU S:%=1 RAELESIG="" "RTN","RARTE",21,0) . K:'$D(RAELESIG) %,%W,%Y,%Y1,C,X,X1,X2 "RTN","RARTE",22,0) . Q "RTN","RARTE",23,0) K RABTCH I $P(RAMDV,"^",13) D ASKBTCH^RARTE1 G Q1^RARTE4:X["^" D 1^RABTCH:"Yy"[$E(X) I '$D(RABTCH) W " ...no batch selected",! "RTN","RARTE",24,0) START K RAVER S RAVW="",RAREPORT=1 D ^RACNLU G Q^RARTE4:"^"[X "RTN","RARTE",25,0) S RASUBY0=Y(0) ; save value of y(0) "RTN","RARTE",26,0) G:$P(^RA(72,+RAST,0),"^",3)>0 DISPLAY "RTN","RARTE",27,0) I $D(^XUSEC("RA MGR",DUZ)) G DISPLAY "RTN","RARTE",28,0) G:$P(RAMDV,"^",22)=1 DISPLAY "RTN","RARTE",29,0) W $C(7),!!,"The STATUS for this case is CANCELLED. You may not enter a report.",!! D INCRPT^RARTE4 G START "RTN","RARTE",30,0) ; "RTN","RARTE",31,0) DISPLAY ; Display exam specific info, edit/enter the report "RTN","RARTE",32,0) N RA18EX S RA18EX=0 ;P18 for quit if uparrow inside PUTTCOM "RTN","RARTE",33,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RARTE",34,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN) "RTN","RARTE",35,0) I '($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))#2) D D Q^RARTE4 QUIT "RTN","RARTE",36,0) . I $$USESSAN^RAHLRU1() W !!?2,"Case #: ",RACNDSP," for ",RANME S RAXIT=1 "RTN","RARTE",37,0) . I '$$USESSAN^RAHLRU1() W !!?2,"Case #: ",RACN," for ",RANME S RAXIT=1 "RTN","RARTE",38,0) . W !?2,"Procedure: '",$E(RAPRC,1,45),"' has been deleted" "RTN","RARTE",39,0) . W !?2,"by another user!",$C(7) "RTN","RARTE",40,0) . Q "RTN","RARTE",41,0) ;Lock case node so no one else can edit rpt pointer during this session "RTN","RARTE",42,0) S RAPNODE="^RADPT("_RADFN_",""DT"","_RADTI_",""P""," "RTN","RARTE",43,0) S RAXIT=$$LOCK^RAUTL12(RAPNODE,RACNI) I RAXIT D INCRPT^RARTE4 G START "RTN","RARTE",44,0) S RAI="",$P(RAI,"-",80)="" W !,RAI "RTN","RARTE",45,0) W !?1,"Name : ",$E(RANME,1,25),?40,"Pt ID : ",RASSN "RTN","RARTE",46,0) I $$USESSAN^RAHLRU1() W !?1,"Case No. : ",RACNDSP,?40,"Exm. St : ",$E($P($G(^RA(72,+RAST,0)),"^"),1,22),!?1,"Procedure: ",$E(RAPRC,1,45) "RTN","RARTE",47,0) I '$$USESSAN^RAHLRU1() W !?1,"Case No. : ",RACN,?18,"Exm. St: ",$E($P($G(^RA(72,+RAST,0)),"^"),1,12),?40,"Procedure : ",$E(RAPRC,1,25) "RTN","RARTE",48,0) ;check for contrast media; display if CM data exists (patch 45) "RTN","RARTE",49,0) S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI) "RTN","RARTE",50,0) D:$L(RACMDATA) CMEDIA(RACMDATA) "RTN","RARTE",51,0) K RACMDATA "RTN","RARTE",52,0) S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,RACN," Tech.Comment: ",15,70,-1,0) ;P18 "RTN","RARTE",53,0) I RA18EX=-1 Q ;P18 "RTN","RARTE",54,0) N RAPRTSET,RAMEMARR,RA1 "RTN","RARTE",55,0) D EN2^RAUTL20(.RAMEMARR) "RTN","RARTE",56,0) I RAPRTSET D "RTN","RARTE",57,0) . S RA1="" "RTN","RARTE",58,0) . F S RA1=$O(RAMEMARR(RA1)) Q:RA1=""!(RA18EX=-1) I RA1'=RACNI D "RTN","RARTE",59,0) .. I $$USESSAN^RAHLRU1() W !,?1,"Case No. : ",$P(RAMEMARR(RA1),U) "RTN","RARTE",60,0) .. I '$$USESSAN^RAHLRU1() W !,?1,"Case No. : ",+RAMEMARR(RA1) "RTN","RARTE",61,0) .. I $$USESSAN^RAHLRU1() W:$P(RAMEMARR(RA1),"^",4)]"" ?40,"Exm. St : ",$E($P($G(^RA(72,$P(RAMEMARR(RA1),"^",4),0)),"^"),1,22) W !?1,"Procedure: ",$E($P($G(^RAMIS(71,+$P(RAMEMARR(RA1),"^",2),0)),"^"),1,45) "RTN","RARTE",62,0) .. I '$$USESSAN^RAHLRU1() W:$P(RAMEMARR(RA1),"^",4)]"" ?18,"Exm. St: ",$E($P($G(^RA(72,$P(RAMEMARR(RA1),"^",4),0)),"^"),1,12) W ?40,"Procedure : ",$E($P($G(^RAMIS(71,+$P(RAMEMARR(RA1),"^",2),0)),"^"),1,26) "RTN","RARTE",63,0) ..;check printset for contrast media; display if CM data exists "RTN","RARTE",64,0) ..S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RA1) "RTN","RARTE",65,0) ..D:$L(RACMDATA) CMEDIA(RACMDATA) "RTN","RARTE",66,0) ..K RACMDATA "RTN","RARTE",67,0) ..I $P(RAMEMARR(RA1),"^")["-" S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,$P($P(RAMEMARR(RA1),"^"),"-",3)," Tech.Comment: ",15,70,-1,0) Q:RA18EX=-1 "RTN","RARTE",68,0) ..I $P(RAMEMARR(RA1),"^")'["-" S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,+RAMEMARR(RA1)," Tech.Comment: ",15,70,-1,0) Q:RA18EX=-1 ;P18 "RTN","RARTE",69,0) .. Q "RTN","RARTE",70,0) . Q "RTN","RARTE",71,0) SS1 I RA18EX=-1 Q ;P18 "RTN","RARTE",72,0) W !?1,"Exam Date: ",RADATE,?40,"Technologist: " I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0))>0,$D(^VA(200,+^($O(^(0)),0),0)) W $E($P(^(0),"^"),1,25) "RTN","RARTE",73,0) W !?1,"Req Phys : ",$E($S($D(^VA(200,+$P(Y(0),"^",14),0)):$P(^(0),"^"),1:""),1,25) "RTN","RARTE",74,0) ; p99: get pt sex and display pregnancy data "RTN","RARTE",75,0) I $$PTSEX^RAUTL8(RADFN)="F" D "RTN","RARTE",76,0) .N RA3,RAPCOMM S RA3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) "RTN","RARTE",77,0) .S RAPCOMM=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"PCOMM")) "RTN","RARTE",78,0) .W:$P(RA3,U,32)'="" !?1,"Pregnancy Screen: ",$S($P(RA3,"^",32)="y":"Patient answered yes",$P(RA3,"^",32)="n":"Patient answered no",$P(RA3,"^",32)="u":"Patient is unable to answer or is unsure",1:"") "RTN","RARTE",79,0) .W:$P(RA3,U,32)'="n"&$L(RAPCOMM) !?1,"Pregnancy Screen Comment: ",RAPCOMM "RTN","RARTE",80,0) S Y(0)=RASUBY0 "RTN","RARTE",81,0) W !,RAI "RTN","RARTE",82,0) ;end p99 "RTN","RARTE",83,0) I $D(^RARPT(+RARPT,0)) S RA1=$P(^(0),"^",5) I "^V^EF^"[("^"_RA1_"^") W !?3,$C(7),"Report has already been ",$S(RA1="V":"verified",1:"electronically filed"),! D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT^RARTE4 G START "RTN","RARTE",84,0) ;Create new rpt, or skip to IN to edit existing report "RTN","RARTE",85,0) G IN^RARTE4:$D(^RARPT(+RARPT,0)) "RTN","RARTE",86,0) G:'RAPRTSET NEW G:$P(^RA(72,+RAST,0),"^",3)>0 NEW "RTN","RARTE",87,0) ; case is part of a print set, AND is cancelled "RTN","RARTE",88,0) N RA2 S (RA1,RA2)="" "RTN","RARTE",89,0) F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" S:$P(RAMEMARR(RA1),"^",3)]"" RA2=$P(RAMEMARR(RA1),"^",3) "RTN","RARTE",90,0) G:RA2="" NEW "RTN","RARTE",91,0) W !!,$C(7),"Other cases of this cancelled case ",RACNDSP,"'s print set are entered in a report already",!!,"You may NOT create a new report for this cancelled case,",!,"but you may include this cancelled case in the existing report." "RTN","RARTE",92,0) W !!,"Do you want to include this cancelled case in the same report",!,"as the others in the print set ?" "RTN","RARTE",93,0) S %=2 D YN^DICN "RTN","RARTE",94,0) W:%>0 "...",$S(%=1:"Include",1:"Skip")," this case" "RTN","RARTE",95,0) I %=1 S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=RA2,RARPT=RA2,RARPTN=$P(^RARPT(RARPT,0),"^"),RA1=RACN D INSERT^RARTE2 "RTN","RARTE",96,0) D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT^RARTE4 G START "RTN","RARTE",97,0) NEW G:'RAPRTSET NEW1 "RTN","RARTE",98,0) L +^RADPT(RADFN,"DT",RADTI):0 G:$T NEW1 "RTN","RARTE",99,0) W !!?10,$C(7),"** This case belongs to a printset,",?68,"**",!?10,"** and someone else is currently doing REPORT ENTRY/EDIT",?68,"**" "RTN","RARTE",100,0) W !?10,"** on another case for this same printset,",?68,"**",!?10,"** so you may not enter a new report.",?68,"**" "RTN","RARTE",101,0) H 2 D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT^RARTE4 G START "RTN","RARTE",102,0) NEW1 ; "RTN","RARTE",103,0) I $L(RACNDSP,"-")>1 S RARPTN=RACNDSP "RTN","RARTE",104,0) I $L(RACNDSP,"-")<2 S RARPTN=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN "RTN","RARTE",105,0) W !?3,"...report not entered for this exam...",!?10,"...will now initialize report entry..." "RTN","RARTE",106,0) S I=+$P(^RARPT(0),"^",3) "RTN","RARTE",107,0) G LOCK^RARTE4 "RTN","RARTE",108,0) Q "RTN","RARTE",109,0) ; "RTN","RARTE",110,0) CMEDIA(X) ;check if contrast media is associated with the report (exam) "RTN","RARTE",111,0) ;variables assumed to exist X: the string of contrast media used "RTN","RARTE",112,0) ;delimited by the comma. "RTN","RARTE",113,0) N Y W !," Contrast :" "RTN","RARTE",114,0) F Y=1:1 Q:$P(X,", ",Y)="" W ?12,$P(X,", ",Y) W:$P(X,", ",Y+1)'="" ! "RTN","RARTE",115,0) Q "RTN","RARTE1") 0^73^B66239828 "RTN","RARTE1",1,0) RARTE1 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Edit/Delete a Report ;6/10/98 16:08 "RTN","RARTE1",2,0) ;;5.0;Radiology/Nuclear Medicine;**2,15,17,23,31,68,56,47**;Mar 16, 1998;Build 21 "RTN","RARTE1",3,0) ;Private IA #4793 DELETE^WVRALINK, CREATE^WVRALINK "RTN","RARTE1",4,0) ;Supported IA #10035 "RTN","RARTE1",5,0) ;Supported IA #10007 "RTN","RARTE1",6,0) ;11/07/2005 KAM/BAY 110020 - Correct DUZ ID from Talk Technology "RTN","RARTE1",7,0) ; During the Unverify process "RTN","RARTE1",8,0) DEL D SET^RAPSET1 I $D(XQUIT) K XQUIT Q "RTN","RARTE1",9,0) S (RAPRG74,RAXIT)=0 "RTN","RARTE1",10,0) S DIC("A")="Select Report Day-Case#: " "RTN","RARTE1",11,0) S DIC("W")="S RA0=^(0) W "" "",$S($D(^DPT(+$P(RA0,""^"",2),0)):$P(^(0),""^""),1:""Unknown"") K RA0 W "" "",$$FLD^RARTFLDS(+Y,""PROC"")" "RTN","RARTE1",12,0) S DIC("S")="I $P(^(0),U,5)'=""X""" ;select only non-deleted reports "RTN","RARTE1",13,0) S DIC="^RARPT(",DIC(0)="AEMQZ" D ^DIC K DIC G END:Y<0 "RTN","RARTE1",14,0) S RA0=Y(0),(DA,RAIEN)=+Y "RTN","RARTE1",15,0) I $O(^RARPT(RAIEN,2005,0)) D D END Q "RTN","RARTE1",16,0) . W !!?5,"Cannot delete a report that is associated with an image." "RTN","RARTE1",17,0) . W !?5,"Contact your Imaging Coordinator for further assistance.",! "RTN","RARTE1",18,0) . S DIR(0)="E",DIR("A")="Press RETURN to continue" "RTN","RARTE1",19,0) . D ^DIR K DIR,DIRUT,DUOUT "RTN","RARTE1",20,0) . Q ;08/23/00 "RTN","RARTE1",21,0) D CHK17^RARTE3 ;see this subroutine for values of RAOK "RTN","RARTE1",22,0) G:RAOK=1 END ;can't del rpt w/o RACN or RACNI so avoid err at UP1^RAUTL1 "RTN","RARTE1",23,0) S RAXIT=$$LOCK^RAUTL12("^RARPT(",RAIEN) "RTN","RARTE1",24,0) I RAXIT K RAXIT D END Q ; record locked by another "RTN","RARTE1",25,0) ASKDEL ; ask if deletion is appropriate "RTN","RARTE1",26,0) R !!,"Do you wish to delete this report? NO// ",X:DTIME "RTN","RARTE1",27,0) S:'$T!(X="")!(X["^") X="N" "RTN","RARTE1",28,0) I "Nn"[$E(X) D UNLOCK^RAUTL12("^RARPT(",RAIEN) G DEL "RTN","RARTE1",29,0) I "Yy"'[$E(X) D G ASKDEL "RTN","RARTE1",30,0) . W:X'["?" $C(7) "RTN","RARTE1",31,0) . W !!?3,"Enter 'YES' to delete this report, or 'NO' not to." "RTN","RARTE1",32,0) . Q "RTN","RARTE1",33,0) ; comment out next line, these 3 vars are already set by CHK17^RARTE3 "RTN","RARTE1",34,0) ;S RADFN=+$P(RA0,"^",2),RADTI=9999999.9999-$P(RA0,"^",3),RACN=$P(RA0,"^",4) "RTN","RARTE1",35,0) G:RAOK=2 AD2 ;don't remove piece 17 if rpt doesn't match exm's rpt ptr "RTN","RARTE1",36,0) ; del other member's REPORT TEXT xrefs, and set pointer to #74 as null "RTN","RARTE1",37,0) D DEL17^RARTE2(RAIEN) ;del ptrs to file 74 excluding lead case of prtset "RTN","RARTE1",38,0) S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) "RTN","RARTE1",39,0) G:'$D(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0))#2 AD2 "RTN","RARTE1",40,0) ; kill any xrefs for file #70's REPORT TEXT "RTN","RARTE1",41,0) S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI D ENKILL^RAXREF(70.03,17,RAIEN,.DA) "RTN","RARTE1",42,0) ; set REPORT TEXT to null "RTN","RARTE1",43,0) S $P(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0),"^",17)="" "RTN","RARTE1",44,0) AD2 K RAXIT S RAPRG74=1 ;RAPRG74 used in kill logic file 74 fld .01 "RTN","RARTE1",45,0) D MARKDEL^RARTE7 ; mark report deleted, save DXs, remov DXs fm case(s) "RTN","RARTE1",46,0) W !?10,"...report deletion complete." "RTN","RARTE1",47,0) D:RAOK'=2 UP1^RAUTL1 ;skip update status if report doesn't belong to exm "RTN","RARTE1",48,0) D UPDTPNT^RAUTL9(RAIEN) ; Update pointers in 74.2, and 74.4! "RTN","RARTE1",49,0) D UNLOCK^RAUTL12("^RARPT(",RAIEN) ; unlock report "RTN","RARTE1",50,0) I RAOK'=2,$T(DELETE^WVRALINK)]"" D DELETE^WVRALINK(RADFN,RADTI,RACNI) ; women's health, skip if report doesn't belong to exm "RTN","RARTE1",51,0) END K %,%Y,D0,DA,DIC,DIE,RAJ1,DIK,RADFN,RADTI,RACN,RACNI,RA0,RAIEN,RAOR "RTN","RARTE1",52,0) K RADUZ,RAORDIFN,RAPRG74,RASN,RASTI,Y "RTN","RARTE1",53,0) K RADATE,RADTE,X "RTN","RARTE1",54,0) K RA791,RACANC,RACN0,RACPT,RACPTNDE,RAI,RAN,RAOBR4,RAPKG,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RASULT,RAXIT "RTN","RARTE1",55,0) K C,D,D1,DDER,DDH,DFN,DI,DISYS,DIWF,DIWL,DIWR,DQ,DR,GMRAL,HLN,HLRESLT,HLSAN,I,VA,VADM,VAERR,X0 "RTN","RARTE1",56,0) Q "RTN","RARTE1",57,0) ; "RTN","RARTE1",58,0) UNVER(RAXRPT) ; unverify a report "RTN","RARTE1",59,0) ; Input: if RAXRPT>0 then we know the report we wish to delete "RTN","RARTE1",60,0) ; this requires no user interaction. "RTN","RARTE1",61,0) ; RAXRPT=0 user is prompted for the report they wish to "RTN","RARTE1",62,0) ; delete (interactive) "RTN","RARTE1",63,0) ; "RTN","RARTE1",64,0) I 'RAXRPT D SET^RAPSET1 G Q:$D(XQUIT) "RTN","RARTE1",65,0) I RAXRPT N X S X=RAXRPT "RTN","RARTE1",66,0) S RAXIT=0,DIC="^RARPT(",DIC("S")="I $P(^(0),U,5)=""V""" "RTN","RARTE1",67,0) S DIC(0)=$S('RAXRPT:"AEMQZ",1:"NZ") "RTN","RARTE1",68,0) D DICW,^DIC K DIC I Y<0 D Q Q "RTN","RARTE1",69,0) S RA74B4=$G(Y(0)) "RTN","RARTE1",70,0) S (RARPT,DA)=+Y,RADFN=$P(Y(0),U,2) "RTN","RARTE1",71,0) S RADTI=9999999.9999-$P(Y(0),"^",3),RACN=$P(Y(0),"^",4) "RTN","RARTE1",72,0) I 'RAXRPT S DR="D EN1^RAUTL9 I $D(DIRUT) S Y=""@99"";S:RASTATX'=""PD"" Y=""@10"";25;@10;5////^S X=RASTATX;S:X=""V"" Y=""@99"";9///@;17///@;100///NOW;@99" "RTN","RARTE1",73,0) S:RAXRPT DR="5////^S X=""D"";9///@;17///@;100///NOW" "RTN","RARTE1",74,0) ;11/07/2005 KAM/BAY 110020 Modified next line to look for voice recognition "RTN","RARTE1",75,0) S DIE="^RARPT(",DR(2,74.01)="2////U;3////"_$S(($D(RAQUIET)#2)&($D(RASUB)#2):$G(^TMP("RARPT-REC",$J,RASUB,"RAVERF")),1:DUZ) "RTN","RARTE1",76,0) S RAXIT=$$LOCK^RAUTL12("^RARPT(",RARPT) "RTN","RARTE1",77,0) I RAXIT D Q QUIT "RTN","RARTE1",78,0) D ^DIE K DE,DQ,DIE,DR D UNLOCK^RAUTL12("^RARPT(",RARPT) "RTN","RARTE1",79,0) N RA1,RA2,RA3,RA4 S RA1=RADFN,RA2=RADTI,RA3=RACN,RA4=RARPT "RTN","RARTE1",80,0) S RA(0)=$G(^RARPT(RARPT,0)),RA(5)=$P(^RARPT(RARPT,0),"^",5) "RTN","RARTE1",81,0) S RA(7)=$P(^RARPT(RARPT,0),"^",7),RA(10)=$P(^RARPT(RARPT,0),"^",10) "RTN","RARTE1",82,0) I RA(5)'="V" D "RTN","RARTE1",83,0) . I RA(7)]"" D ENKILL^RAXREF(74,7,RA(7),RARPT) S $P(^RARPT(RARPT,0),"^",7)="" "RTN","RARTE1",84,0) . I RA(10)]"" D ENKILL^RAXREF(74,10,RA(10),RARPT) S $P(^RARPT(RARPT,0),"^",10)="" "RTN","RARTE1",85,0) . N RADDEN,RAUTOE S (RADDEN,RAUTOE)="" D ^RARTR,EN1^RARTE3(RA4) "RTN","RARTE1",86,0) . Q "RTN","RARTE1",87,0) S RADFN=RA1,RADTI=RA2,RACN=RA3,RARPT=RA4 "RTN","RARTE1",88,0) S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) I $D(^RADPT(RADFN,"DT",RADTI,"P",+RACNI,0)) D UP1^RAUTL1 I $D(^RABTCH(74.4,"B",RARPT)) D "RTN","RARTE1",89,0) .S DA=0 F S DA=$O(^RABTCH(74.4,"B",RARPT,DA)) Q:'DA D "RTN","RARTE1",90,0) ..S DIK="^RABTCH(74.4," D ^DIK "RTN","RARTE1",91,0) ..Q "RTN","RARTE1",92,0) .Q "RTN","RARTE1",93,0) I "^V^EF^"'[("^"_$P($G(^RARPT(RARPT,0)),"^",5)_"^"),$T(DELETE^WVRALINK)]"" D DELETE^WVRALINK(RADFN,RADTI,RACNI) ; women's health "RTN","RARTE1",94,0) ; "RTN","RARTE1",95,0) Q ; Kill and quit "RTN","RARTE1",96,0) K DFN,DI,DIW,DIWF,DIWI,DIWL,DIWT,DIWTC,DIWX,RAACNT,RANUM,RAST,RAWHOVER "RTN","RARTE1",97,0) K %,%DT,%W,%Y,%Y1,C,D,D0,D1,DA,DIC,DIE,DIK,DR,RA,RACN,RACNI,RADATE "RTN","RARTE1",98,0) K RADFN,RADIV,RADTE,RADTI,RAJ,RAOR,RAORDIFN,RARPT,RASET,RASN,RASTATX "RTN","RARTE1",99,0) K RASTI,RAXIT,X,XQUIT,Y,RA74B4,DDH,DIPGM,DISYS,I,RADUZ "RTN","RARTE1",100,0) Q "RTN","RARTE1",101,0) ; "RTN","RARTE1",102,0) STD S (RALR,RALI)=1 "RTN","RARTE1",103,0) STD1 S DIC="^RA(74.1,",DIC("A")="Select 'Standard' Report to Copy: ",DIC(0)="AEMQ" D ^DIC K DIC("A") Q:Y<0 "RTN","RARTE1",104,0) ASKSEL W:$$IMPRPT(RARPT) !!,"Report already exists. This will over-write it." "RTN","RARTE1",105,0) W !,"Are you sure you want the '",$P(Y,"^",2),"' standard report? No// " R X:DTIME G STD1:'$T!(X="")!(X["^")!("Nn"[$E(X)) "RTN","RARTE1",106,0) I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to select the '",$P(Y,"^",2),"' standard report, or 'NO' not to." G ASKSEL "RTN","RARTE1",107,0) I RALR=1,RALI=1 K ^RARPT(RARPT,"R"),^("I") "RTN","RARTE1",108,0) F I=1:1 Q:'$D(^RA(74.1,+Y,"R",I,0)) S ^RARPT(RARPT,"R",RALR,0)=^(0),RALR=RALR+1 "RTN","RARTE1",109,0) F I=1:1 Q:'$D(^RA(74.1,+Y,"I",I,0)) S ^RARPT(RARPT,"I",RALI,0)=^(0),RALI=RALI+1 "RTN","RARTE1",110,0) ASKADD R !!,"Do you want to add another standard to this report? No// ",X:DTIME Q:'$T!(X="")!(X["^")!("Nn"[$E(X)) I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to add another standard to this report, or 'NO' not to." G ASKADD "RTN","RARTE1",111,0) S (^RARPT(RARPT,"R",RALR,0),^RARPT(RARPT,"I",RALI,0))="",RALR=RALR+1,RALI=RALI+1 W ! G STD1 "RTN","RARTE1",112,0) ; "RTN","RARTE1",113,0) EDTRPT ; Called from 'RARTE4' and 'RARTVER'. "RTN","RARTE1",114,0) N RAXIT S RACT=$S('+$G(^RARPT(RARPT,"T")):"I",1:"E") "RTN","RARTE1",115,0) S:'$D(^RARPT(RARPT,"T")) ^("T")="" "RTN","RARTE1",116,0) S DA=RARPT,DR="[RA REPORT EDIT]",DIE="^RARPT(" D ^DIE K DE,DQ ;,RAFLAGK "RTN","RARTE1",117,0) I $D(Y),RACT="V",'$P(^RARPT(RARPT,0),"^",9) W !,$C(7),"You must enter a verifying Interpreting Physician to 'VERIFY' a report.",!?3,"...report status will now be changed to 'DRAFT'." S DA=RARPT,DR="5///D" D ^DIE K DE,DQ ;Q "RTN","RARTE1",118,0) Q:$D(RAONLINE)&($G(RARDX)="E") "RTN","RARTE1",119,0) ; move PACS line to its own subroutine "RTN","RARTE1",120,0) ;I $D(RAFLAGK) K RAFLAGK Q "RTN","RARTE1",121,0) G:$D(Y) PACS "RTN","RARTE1",122,0) ;Since report editing is not necessarily screened by sign-on imaging "RTN","RARTE1",123,0) ;type, use the imaging type on the exam record ;ch "RTN","RARTE1",124,0) S RAIMGTYI=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2),RAIMGTYJ=$P($G(^RA(79.2,+RAIMGTYI,0)),U) "RTN","RARTE1",125,0) S X=+$O(^RA(72,"AA",RAIMGTYJ,9,0)),DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," K RAIMGTYI,RAIMGTYJ "RTN","RARTE1",126,0) S DR=13_$S(RACT'="V":"",'$D(^RA(72,X,.1)):"",$P(^(.1),"^",5)'="Y":"",1:"R")_";I $D(^RA(78.3,+X,0)),$P(^(0),""^"",4)=""y"" S RAAB=1" "RTN","RARTE1",127,0) ; "RTN","RARTE1",128,0) ;lock the correct sub-file (pset?) "RTN","RARTE1",129,0) D DXLOC "RTN","RARTE1",130,0) ; "RTN","RARTE1",131,0) I RACT="V",$P($G(^RA(72,X,.1)),"^",5)="Y" S DIE("NO^")="BACK" "RTN","RARTE1",132,0) I 'RAXIT D ^DIE K DA,DE,DQ,DIE,DR "RTN","RARTE1",133,0) I RAXIT!($P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)="")!($D(Y)) D DXULOC G PACS "RTN","RARTE1",134,0) S DR="50///"_RACN "RTN","RARTE1",135,0) S DR(2,70.03)=13.1 "RTN","RARTE1",136,0) S DR(3,70.14)=.01_";I $D(^RA(78.3,+X,0)),$P(^(0),""^"",4)=""y"" S RAAB=1" "RTN","RARTE1",137,0) S DA(1)=RADFN,DA=RADTI,DIE="^RADPT("_DA(1)_",""DT""," "RTN","RARTE1",138,0) ; "RTN","RARTE1",139,0) I 'RAXIT D ^DIE K DA,DE,DQ,DIE,DR "RTN","RARTE1",140,0) ; "RTN","RARTE1",141,0) COPYDX ;if we have a printset copy over the Dx code data (both primary & secondary) "RTN","RARTE1",142,0) ;to all our descendents before building our HL7 ORU messsages. "RTN","RARTE1",143,0) I RAPRTSET S RADRS=1,RAXIT=0 D COPY^RARTE2 ;P47 "RTN","RARTE1",144,0) ;unlock the correct sub-file (pset?) "RTN","RARTE1",145,0) D DXULOC "RTN","RARTE1",146,0) ; "RTN","RARTE1",147,0) PACS I ($P(^RARPT(RARPT,0),U,5)="V")!($P(^(0),U,5)="R") D RPT^RAHLRPC "RTN","RARTE1",148,0) I "^V^EF"[("^"_$P(^RARPT(RARPT,0),U,5)_"^"),$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ; women's health "RTN","RARTE1",149,0) Q "RTN","RARTE1",150,0) ; "RTN","RARTE1",151,0) ASKBTCH R !!,"Do you want to batch print reports? Yes// ",X:DTIME S:'$T X="^" S:X="" X="Y" Q:X["^" I "Nn"'[$E(X),"Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to batch print reports, or 'NO' not to." G ASKBTCH "RTN","RARTE1",152,0) Q "RTN","RARTE1",153,0) ; "RTN","RARTE1",154,0) ASKPRT R !!,"Do you want to print batch now? No// ",X:DTIME S:'$T!(X="")!(X["^") X="N" I "Nn"'[$E(X),"Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to print this batch, or 'NO' not to." G ASKPRT "RTN","RARTE1",155,0) Q "RTN","RARTE1",156,0) DICW ; Build DIC("W") string "RTN","RARTE1",157,0) N DO D DO^DIC1 "RTN","RARTE1",158,0) S DIC("W")=$S($G(DIC("W"))]"":DIC("W")_" ",1:"")_"W "" "",$$FLD^RARTFLDS(+Y,""PROC"")" "RTN","RARTE1",159,0) Q "RTN","RARTE1",160,0) IMPRPT(Y) ; Does the report we are currently editing have either Report "RTN","RARTE1",161,0) ; or Impression Text? "RTN","RARTE1",162,0) ; Input : 'Y' - the ien of the report being edited "RTN","RARTE1",163,0) ; Output: '1' - either impression or report text exists, '0' - neither "RTN","RARTE1",164,0) ; report or impression text exists. "RTN","RARTE1",165,0) Q $S(+$O(^RARPT(Y,"I",0)):1,+$O(^RARPT(Y,"R",0)):1,1:0) "RTN","RARTE1",166,0) ; "RTN","RARTE1",167,0) DXLOC ;lock the correct RAD/NUC MED PATIENT sub-file "RTN","RARTE1",168,0) S:'RAPRTSET RAXIT=$$LOCK^RAUTL12("^RADPT("_RADFN_",""DT"","_RADTI_",""P"",",RACNI) "RTN","RARTE1",169,0) S:RAPRTSET RAXIT=$$LOCK^RAUTL12("^RADPT("_RADFN_",""DT"",",RADTI) "RTN","RARTE1",170,0) Q "RTN","RARTE1",171,0) ; "RTN","RARTE1",172,0) DXULOC ;unlock the correct RAD/NUC MED PATIENT sub-file "RTN","RARTE1",173,0) D:'RAPRTSET UNLOCK^RAUTL12("^RADPT("_RADFN_",""DT"","_RADTI_",""P"",",RACNI) "RTN","RARTE1",174,0) D:RAPRTSET UNLOCK^RAUTL12("^RADPT("_RADFN_",""DT"",",RADTI) "RTN","RARTE1",175,0) Q "RTN","RARTE1",176,0) ; "RTN","RARTE2") 0^65^B32141462 "RTN","RARTE2",1,0) RARTE2 ;HISC/SWM-Edit/Delete a Report ;7/16/01 14:05 "RTN","RARTE2",2,0) ;;5.0;Radiology/Nuclear Medicine;**10,31,47**;Mar 16, 1998;Build 21 "RTN","RARTE2",3,0) ; known vars-->RADFN,RACNI,RADTI,RARPT,RARPTN "RTN","RARTE2",4,0) PTR ; if current ^RADPT() rec is a PRINT SET, "RTN","RARTE2",5,0) ; then for other ^RADPT() recs of the same PRINT SET, "RTN","RARTE2",6,0) ; create its corresponding subrec in ^RARPT() "RTN","RARTE2",7,0) S RAXIT=0 "RTN","RARTE2",8,0) I '$D(RADFN)!'$D(RACNI)!'$D(RADTI)!'$D(RARPT)!'$D(RARPTN) D Q "RTN","RARTE2",9,0) . S RAXIT=1 Q:$G(RARIC) "RTN","RARTE2",10,0) . I '$D(RAQUIET) W !!,$C(7),"Missing data (routine RARTE2)",! S RAOUT=$$EOS^RAUTL5() Q "RTN","RARTE2",11,0) . S RAERR="Missing data needed by routine RARTE2" "RTN","RARTE2",12,0) . Q "RTN","RARTE2",13,0) N RA1,RA2,RA3,RAFDA,RAIEN,RAMSG ;RA3=exam status "RTN","RARTE2",14,0) S RA1=0 "RTN","RARTE2",15,0) PTR2 S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RA1)) Q:RA1="" S RA2=$O(^(RA1,0)),RA3=$P(^RADPT(RADFN,"DT",RADTI,"P",RA2,0),"^",3) G:$P(^(0),"^",25)'=2 PTR2 ;skip non-combined rpt "RTN","RARTE2",16,0) G:RA2=RACNI PTR2 ;skip already processed case "RTN","RARTE2",17,0) K RAFDA,RAIEN,RAMSG "RTN","RARTE2",18,0) ASK G:$G(RARIC) UPD G:$D(RAQUIET) UPD ; don't ask, if from Img pkg or Kurzweil "RTN","RARTE2",19,0) I $P(^RA(72,+RA3,0),"^",3)=0 D G:%=2 PTR2 G:%'=1 ASK "RTN","RARTE2",20,0) . W !!,"Case ",RA1," of this print set has been cancelled." "RTN","RARTE2",21,0) . W !,"Do you want to include it in the report anyway" "RTN","RARTE2",22,0) . S %=2 D YN^DICN "RTN","RARTE2",23,0) . W:%>0 "...",$S(%=2:"Ex",%=1:"In",1:""),"clude case ",RA1 "RTN","RARTE2",24,0) . Q "RTN","RARTE2",25,0) ; update file #70, field REPORT TEXT "RTN","RARTE2",26,0) UPD S $P(^RADPT(RADFN,"DT",RADTI,"P",RA2,0),U,17)=RARPT "RTN","RARTE2",27,0) D INSERT "RTN","RARTE2",28,0) Q:RAXIT G PTR2 "RTN","RARTE2",29,0) INSERT ; add subrec to file #74's subfile #74.05 "RTN","RARTE2",30,0) ; P47 - if SSAN in use set OTHER CASES in Printset to SSAN format "RTN","RARTE2",31,0) I $L(RARPTN,"-")>2 S RAFDA(74.05,"?+2,"_RARPT_",",.01)=$P(RARPTN,"-",1,2)_"-"_RA1 "RTN","RARTE2",32,0) I $L(RARPTN,"-")<3 S RAFDA(74.05,"?+2,"_RARPT_",",.01)=$P(RARPTN,"-")_"-"_RA1 "RTN","RARTE2",33,0) D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") "RTN","RARTE2",34,0) I $D(RAMSG) D Q "RTN","RARTE2",35,0) . S RAXIT=1 Q:$G(RARIC) "RTN","RARTE2",36,0) . I '$D(RAQUIET) W !!,$C(7),"Error encountered while setting sub-records (routine RARTE2)",! S RAOUT=$$EOS^RAUTL5() Q ;error detected "RTN","RARTE2",37,0) . S RAERR="Error encountered while setting sub-recs from RARTE2" "RTN","RARTE2",38,0) Q "RTN","RARTE2",39,0) DEL17(RAIEN) ;del other print set members' pointer to #74 "RTN","RARTE2",40,0) Q:'$D(RADFN)!('$D(RADTI)) "RTN","RARTE2",41,0) N RA4,RA1 D EN3^RAUTL20(.RA4) "RTN","RARTE2",42,0) Q:'$O(RA4(0)) "RTN","RARTE2",43,0) S RA1="" "RTN","RARTE2",44,0) D18 S RA1=$O(RA4(RA1)) Q:RA1="" "RTN","RARTE2",45,0) ; kill xrefs, if any, for file #70's REPORT TEXT "RTN","RARTE2",46,0) S DA(2)=RADFN,DA(1)=RADTI,DA=RA1 "RTN","RARTE2",47,0) ; if this exam's piece 17 doesn't match RAIEN, then don't remove pc17 "RTN","RARTE2",48,0) I $P($G(^RADPT(RADFN,"DT",RADTI,"P",RA1,0)),"^",17)'=RAIEN G D18 "RTN","RARTE2",49,0) D ENKILL^RAXREF(70.03,17,RAIEN,.DA) "RTN","RARTE2",50,0) ; set REPORT TEXT to null "RTN","RARTE2",51,0) S:$D(^RADPT(RADFN,"DT",RADTI,"P",RA1,0)) $P(^(0),"^",17)="" "RTN","RARTE2",52,0) G D18 "RTN","RARTE2",53,0) COPY ;copy physicians and diagnoses "RTN","RARTE2",54,0) Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))!('$D(RAMEMARR))!('$D(RADRS)) "RTN","RARTE2",55,0) W !!,"... now copying ",$S(RADRS=1:"Diagnostic Codes",1:"Staff & Resident data")," to other cases in this print set ...",! "RTN","RARTE2",56,0) N RA1,RA2,RA3 "RTN","RARTE2",57,0) N RA1PR,RA1PS ;prim res/staff "RTN","RARTE2",58,0) N RA1SR,RA1SS ; sec res/staff arrays--(ien subfile #70.11)=ien file #200 "RTN","RARTE2",59,0) N RA1PD,RA1SD ; prim diag, then sec diags array "RTN","RARTE2",60,0) N RAFDA,RAIEN,RAMSG "RTN","RARTE2",61,0) ;prim res, prim staff, prim diag "RTN","RARTE2",62,0) S RA1=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) S:RADRS=2 RA1PR=$P(RA1,"^",12),RA1PS=$P(RA1,"^",15) S:RADRS=1 RA1PD=$P(RA1,"^",13) "RTN","RARTE2",63,0) ;sec residents "RTN","RARTE2",64,0) I RADRS=2,$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",0)) S RA1=0 F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RA1)) Q:+RA1'=RA1 S RA1SR(RA1)=+^(RA1,0) "RTN","RARTE2",65,0) ;sec staff "RTN","RARTE2",66,0) I RADRS=2,$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",0)) S RA1=0 F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RA1)) Q:+RA1'=RA1 S RA1SS(RA1)=+^(RA1,0) "RTN","RARTE2",67,0) ;sec diagnoses "RTN","RARTE2",68,0) I RADRS=1,$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) S RA1=0 F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RA1)) Q:+RA1'=RA1 S RA1SD(RA1)=+^(RA1,0) "RTN","RARTE2",69,0) ;loop thru other cases of this printset "RTN","RARTE2",70,0) S RA1=0 "RTN","RARTE2",71,0) COPYLOOP S RA1=$O(RAMEMARR(RA1)) G:RA1="" COPYREF G:RA1=RACNI COPYLOOP ;skip what's done already "RTN","RARTE2",72,0) ; "RTN","RARTE2",73,0) ; copy primary staff and resident via Fileman "RTN","RARTE2",74,0) I RADRS=2 D "RTN","RARTE2",75,0) . S DA(2)=RADFN,DA(1)=RADTI,DA=RA1 "RTN","RARTE2",76,0) . S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," "RTN","RARTE2",77,0) . S DR="12////"_RA1PR_";15////"_RA1PS "RTN","RARTE2",78,0) . D ^DIE K DA,DIE,DR ; no locking "RTN","RARTE2",79,0) . Q "RTN","RARTE2",80,0) ; "RTN","RARTE2",81,0) ; copy primary diagnostic code via Fileman "RTN","RARTE2",82,0) I RADRS=1 D "RTN","RARTE2",83,0) . S DA(2)=RADFN,DA(1)=RADTI,DA=RA1 "RTN","RARTE2",84,0) . S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," "RTN","RARTE2",85,0) . S DR="13////"_RA1PD "RTN","RARTE2",86,0) . D ^DIE K DA,DIE,DR ; no locking "RTN","RARTE2",87,0) . Q "RTN","RARTE2",88,0) ; "RTN","RARTE2",89,0) S RA2=RA1_","_RADTI_","_RADFN ;stem for dataserver call "RTN","RARTE2",90,0) S DA(3)=RADFN,DA(2)=RADTI,DA(1)=RA1 ;base vars for DIK call "RTN","RARTE2",91,0) I RADRS=2 S RA3=0 D KIL3 G:RAXIT Q ; sec res "RTN","RARTE2",92,0) I RADRS=2 S RA3=0 D KIL4 G:RAXIT Q ; sec staff "RTN","RARTE2",93,0) I RADRS=1 S RA3=0 D KIL5 G:RAXIT Q ; sec diag "RTN","RARTE2",94,0) G COPYLOOP "RTN","RARTE2",95,0) KIL3 S RA3=$O(^RADPT(RADFN,"DT",RADTI,"P",RA1,"SRR",RA3)) G:RA3="" COPY3 "RTN","RARTE2",96,0) S DA=RA3 "RTN","RARTE2",97,0) S DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""SRR""," "RTN","RARTE2",98,0) D ^DIK "RTN","RARTE2",99,0) G KIL3 "RTN","RARTE2",100,0) COPY3 K RAFDA,RAIEN,RAMSG S RA3=$O(RA1SR(RA3)) Q:'RA3 Q:RAXIT "RTN","RARTE2",101,0) UP3 ; "RTN","RARTE2",102,0) S RAFDA(70.09,"?+2,"_RA2_",",.01)=RA1SR(RA3) "RTN","RARTE2",103,0) D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") G:'$D(RAMSG) COPY3 "RTN","RARTE2",104,0) S RAXIT=1 W !!,$C(7),"Error encountered while in adding rec ",RA3," to sub-file 70.09" Q "RTN","RARTE2",105,0) KIL4 S RA3=$O(^RADPT(RADFN,"DT",RADTI,"P",RA1,"SSR",RA3)) G:RA3="" COPY4 "RTN","RARTE2",106,0) S DA=RA3 "RTN","RARTE2",107,0) S DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""SSR""," "RTN","RARTE2",108,0) D ^DIK "RTN","RARTE2",109,0) G KIL4 "RTN","RARTE2",110,0) COPY4 K RAFDA,RAIEN,RAMSG S RA3=$O(RA1SS(RA3)) Q:'RA3 Q:RAXIT "RTN","RARTE2",111,0) UP4 ; "RTN","RARTE2",112,0) S RAFDA(70.11,"?+2,"_RA2_",",.01)=RA1SS(RA3) "RTN","RARTE2",113,0) D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") G:'$D(RAMSG) COPY4 "RTN","RARTE2",114,0) S RAXIT=1 W !!,$C(7),"Error encountered while in adding rec ",RA3," to sub-file 70.11" Q "RTN","RARTE2",115,0) KIL5 S RA3=$O(^RADPT(RADFN,"DT",RADTI,"P",RA1,"DX",RA3)) G:RA3="" COPY5 "RTN","RARTE2",116,0) S DA=RA3 "RTN","RARTE2",117,0) S DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""DX""," "RTN","RARTE2",118,0) D ^DIK "RTN","RARTE2",119,0) G KIL5 "RTN","RARTE2",120,0) COPY5 K RAFDA,RAIEN,RAMSG S RA3=$O(RA1SD(RA3)) Q:'RA3 Q:RAXIT "RTN","RARTE2",121,0) UP5 ; "RTN","RARTE2",122,0) S RAFDA(70.14,"?+2,"_RA2_",",.01)=RA1SD(RA3) "RTN","RARTE2",123,0) D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") G:'$D(RAMSG) COPY5 "RTN","RARTE2",124,0) S RAXIT=1 W !!,$C(7),"Error encountered while in adding rec ",RA3," to sub-file 70.14" Q "RTN","RARTE2",125,0) COPYREF ; clear out Fileman vars and quit "RTN","RARTE2",126,0) K DA,DIK "RTN","RARTE2",127,0) Q ; don't need to re-xref again "RTN","RARTE2",128,0) Q K DA Q "RTN","RARTE3") 0^51^B5378644 "RTN","RARTE3",1,0) RARTE3 ;HISC/GJC-Create a skeletal report, store in Error Reports multiple ;2/4/97 09:39 "RTN","RARTE3",2,0) ;;5.0;Radiology/Nuclear Medicine;**31,56,47**;Mar 16, 1998;Build 21 "RTN","RARTE3",3,0) ;Supported IA #10103 NOW^XLFDT "RTN","RARTE3",4,0) ;Supported IA #2053 UPDATE^DIE "RTN","RARTE3",5,0) ; This routine will be accessed when the user unverifies a report. "RTN","RARTE3",6,0) ; At this time, a skeletal copy of the report will be stored off "RTN","RARTE3",7,0) ; in the 'Error Reports' multiple. This will keep track of report "RTN","RARTE3",8,0) ; addendums. "RTN","RARTE3",9,0) EN1(RADA) ; Create the 'Error Reports' sub-record. "RTN","RARTE3",10,0) ; Input: 'RADA': IEN of the report in file 74. "RTN","RARTE3",11,0) ; Create the record, enter when the report was unverified. "RTN","RARTE3",12,0) Q:'($D(^TMP($J,"RA AUTOE"))\10) "RTN","RARTE3",13,0) N RACNT,RAIEN,RANEW,RANOW,X S RANOW=$$NOW^XLFDT() "RTN","RARTE3",14,0) S RANEW(74.06,"+1,"_RADA_",",.01)=RANOW "RTN","RARTE3",15,0) D UPDATE^DIE("","RANEW","RAIEN","") "RTN","RARTE3",16,0) ; Error Report date/time field created, now the skeletal report text "RTN","RARTE3",17,0) S RADA(1)=RADA,RADA=+$G(RAIEN(1)) Q:'RADA ; sub-file ien not created "RTN","RARTE3",18,0) S RACNT=+$O(^TMP($J,"RA AUTOE",999999999999),-1) "RTN","RARTE3",19,0) D ZERO K ^TMP($J,"RA AUTOE") "RTN","RARTE3",20,0) Q "RTN","RARTE3",21,0) ZERO ; setup the ^TMP($J,"RA AUTOE" global with a zero node "RTN","RARTE3",22,0) S ^RARPT(RADA(1),"ERR",RADA,"RPT",0)="^^"_RACNT_"^"_RACNT_"^"_(RANOW\1)_"^" "RTN","RARTE3",23,0) N I S I=0 "RTN","RARTE3",24,0) F S I=$O(^TMP($J,"RA AUTOE",I)) Q:I'>0 D "RTN","RARTE3",25,0) . S ^RARPT(RADA(1),"ERR",RADA,"RPT",I,0)=$G(^TMP($J,"RA AUTOE",I)) "RTN","RARTE3",26,0) . Q "RTN","RARTE3",27,0) Q "RTN","RARTE3",28,0) CHK17 ; called from routine RARTE1 "RTN","RARTE3",29,0) ; check 17th piece of exam with same pat/dttm/longcn "RTN","RARTE3",30,0) ; values of RAOK: "RTN","RARTE3",31,0) ; 1 = unknown case no. or unknown case ien, CAN'T DELETE REPORT "RTN","RARTE3",32,0) ; 2 = exm doesn't point to this rpt, CAN DELETE BUT NOT UPGRADE EXM STAT "RTN","RARTE3",33,0) ; 3 = all okay "RTN","RARTE3",34,0) S RAOK=3 "RTN","RARTE3",35,0) S RADFN=+$P(RA0,"^",2),RADTI=9999999.9999-$P(RA0,"^",3) "RTN","RARTE3",36,0) ;S RACN=$P($P(RA0,"^"),"-",2) ;get from longcase no.'s 2nd part "RTN","RARTE3",37,0) ;P47 replace above line-get case from LAST piece not 2nd (could be SSAN) "RTN","RARTE3",38,0) S RACN=$P(RA0,"^") S RACN=$P(RACN,"-",$L(RACN,"-")) "RTN","RARTE3",39,0) I RACN="" D WARN1,PRESS Q "RTN","RARTE3",40,0) S RACNI=+$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) "RTN","RARTE3",41,0) I 'RACNI D WARN1,PRESS Q "RTN","RARTE3",42,0) I $P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",17)'=RAIEN D WARN2,PRESS "RTN","RARTE3",43,0) Q "RTN","RARTE3",44,0) WARN1 W !!?3,"** Cannot determine internal or external case number. **" "RTN","RARTE3",45,0) W !!?3,"** You may NOT delete this report. **" "RTN","RARTE3",46,0) S RAOK=1 "RTN","RARTE3",47,0) Q "RTN","RARTE3",48,0) WARN2 W !!?3,"** This report refers to an exam that isn't pointing back to this report. **" "RTN","RARTE3",49,0) S RAOK=2 "RTN","RARTE3",50,0) WARNQ W !!?3,"** You may delete this report if it is indeed the report you don't want. **" "RTN","RARTE3",51,0) W !?3,"** Or call IRM for help. **" "RTN","RARTE3",52,0) Q "RTN","RARTE3",53,0) PRESS R !!?5,"Press RETURN to continue. ",X:DTIME "RTN","RARTE3",54,0) Q "RTN","RARTE4") 0^74^B25063198 "RTN","RARTE4",1,0) RARTE4 ;HISC/GJC - Edit/Delete Reports (cont) ;11/4/97 08:02 "RTN","RARTE4",2,0) ;;5.0;Radiology/Nuclear Medicine;**15,27,41,82,56,47**;Mar 16, 1998;Build 21 "RTN","RARTE4",3,0) ;Supported IA #10060 ^VA(200 "RTN","RARTE4",4,0) ;Supported IA #10007 DO^DIC1 "RTN","RARTE4",5,0) LOCK ;Try to lock next avail IEN, if locked - fail, if used - increment again "RTN","RARTE4",6,0) S I=I+1 S RAXIT=$$LOCK^RAUTL12("^RARPT(",I) I RAXIT D UNLOCK2 D INCRPT G START^RARTE "RTN","RARTE4",7,0) I $D(^RARPT(I))!($D(^RARPT("B",I))) D UNLOCK^RAUTL12("^RARPT(",I) G LOCK "RTN","RARTE4",8,0) S ^RARPT(I,0)=RARPTN,RARPT=I,^(0)=$P(^RARPT(0),"^",1,2)_"^"_I_"^"_($P(^(0),"^",4)+1),^DISV($S($D(DUZ)#2:DUZ,1:0),"^RARPT(")=I S:'$D(^RARPT(RARPT,"T")) ^("T")="" "RTN","RARTE4",9,0) S ^RARPT(RARPT,0)=RARPTN_"^"_RADFN_"^"_RADTE_"^"_RACN_"^D",DIK="^RARPT(",DA=RARPT D IX1^DIK "RTN","RARTE4",10,0) K %,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y "RTN","RARTE4",11,0) S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI "RTN","RARTE4",12,0) S DIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P""," "RTN","RARTE4",13,0) S DR="17////"_RARPT D ^DIE "RTN","RARTE4",14,0) K %,D,D0,DA,DI,DIC,DIE,DQ,DR,RAY1,X,Y "RTN","RARTE4",15,0) I RAPRTSET D PTR^RARTE2 "RTN","RARTE4",16,0) I RAXIT D UNLOCK2,UNLOCK^RAUTL12("^RARPT(",RARPT) Q "RTN","RARTE4",17,0) G IN0 "RTN","RARTE4",18,0) IN ;lock rpt for the 1st time if editing existing rpt "RTN","RARTE4",19,0) S RAXIT=$$LOCK^RAUTL12("^RARPT(",RARPT) I RAXIT D UNLOCK2,Q Q "RTN","RARTE4",20,0) IN0 ;skip to here if rpt created in this session and already locked "RTN","RARTE4",21,0) G IN1:'$P(RAMDV,"^",14) K RACOPY "RTN","RARTE4",22,0) S DIC("S")="I RARPT'=+Y,$P(^(0),U,5)'=""X""" ;omit same & deleted rpt "RTN","RARTE4",23,0) ; Remedy ticket #245679, remove multi-index lookup "RTN","RARTE4",24,0) S DIC("A")="Select Report to Copy: ",DIC(0)="AEQ",DIC="^RARPT(" "RTN","RARTE4",25,0) D DICW,^DIC K DIC("S"),DIC("A") S RAY1=Y "RTN","RARTE4",26,0) I X="^" D UNLOCK^RAUTL12("^RARPT(",RARPT),UNLOCK2 S RAXIT=$$EN3^RAUTL15(RARPT) D INCRPT G START^RARTE "RTN","RARTE4",27,0) G IN1:RAY1<0 "RTN","RARTE4",28,0) F J="H","R","I" K ^RARPT(RARPT,J) "RTN","RARTE4",29,0) F J="R","I" F I=1:1 Q:'$D(^RARPT(+Y,J,I,0)) S ^RARPT(RARPT,J,I,0)=^(0) "RTN","RARTE4",30,0) ;F I=1:1 Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",1,"H",I,0)) S ^RARPT(RARPT,"H",I,0)=^RADPT(RADFN,"DT",RADTI,"P",1,"H",I,0) "RTN","RARTE4",31,0) S RACOPY="" "RTN","RARTE4",32,0) IN1 ;skip to here if div param disallows rpt copying "RTN","RARTE4",33,0) I $P(RAMDV,"^",14) W !,RAI "RTN","RARTE4",34,0) K RAFIN "RTN","RARTE4",35,0) S DR="50///"_RACN "RTN","RARTE4",36,0) S DR(2,70.03)="12//^S X=$S($D(RARES)&($D(RABTCH)):RARES,1:"""");S:$D(^VA(200,+X,0)) RARES=$P(^(0),U);I X'>0 S Y=""@15"";70;@15;15" "RTN","RARTE4",37,0) I $P(RAMDV,"^",28) S DR(2,70.03)=DR(2,70.03)_"R" ; req'd for DIVISION "RTN","RARTE4",38,0) S DR(2,70.03)=DR(2,70.03)_"//^S X=$S($D(RASTFF)&($D(RABTCH)):RASTFF,1:"""");S:$D(^VA(200,+X,0)) RASTFF=$P(^(0),U);I X'>0 S Y=""@1"";60;@1;S RAFIN=""""" "RTN","RARTE4",39,0) S DA(1)=RADFN,DA=RADTI,DIE="^RADPT("_DA(1)_",""DT""," D ^DIE K DE,DQ "RTN","RARTE4",40,0) D ELOC^RABWRTE ; Billing Aware -- ask Inter. Img Loc "RTN","RARTE4",41,0) I RAPRTSET S RADRS=2 D COPY^RARTE2 ; copy resid and staff "RTN","RARTE4",42,0) G PRT:'$D(RAFIN) W !,RAI "RTN","RARTE4",43,0) ; "RTN","RARTE4",44,0) ; **BNT - Commented out to stop copying history from file 70 to 74 "RTN","RARTE4",45,0) ; in patch RA*5*27. The history is now referenced directly from file 70. "RTN","RARTE4",46,0) ; I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H")),'$D(^RARPT(RARPT,"H")) F I=1:1 Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"H",I,0)) S ^RARPT(RARPT,"H",I,0)=^(0) "RTN","RARTE4",47,0) ; ** "RTN","RARTE4",48,0) I '$D(RACOPY),$P(RAMDV,"^",12) D STD^RARTE1 I X="^" G PRT "RTN","RARTE4",49,0) W !,RAI D EDTRPT^RARTE1 "RTN","RARTE4",50,0) PRT D UNLOCK^RAUTL12(RAPNODE,RACNI) "RTN","RARTE4",51,0) ; wait til report has been checked for completeness before unlocking it "RTN","RARTE4",52,0) S RAXIT=$$EN3^RAUTL15(RARPT) D UNLOCK^RAUTL12("^RARPT(",RARPT) "RTN","RARTE4",53,0) I RAXIT S RAXIT=0 D UNLOCK2 D INCRPT G START^RARTE "RTN","RARTE4",54,0) ; --- "RTN","RARTE4",55,0) D K RAAB G PRT1:'$D(RABTCH),PRT1:'$D(^RABTCH(74.2,+RABTCH,0)) "RTN","RARTE4",56,0) .; RAHLTCPB flag is inactive "RTN","RARTE4",57,0) .N RAHLTCPB S RAHLTCPB=1 D:$S('$D(RACT):0,RACT="V":1,1:0) UPSTAT^RAUTL0 "RTN","RARTE4",58,0) .D:$S('$D(RACT):1,RACT'="V":1,1:0) UP1^RAUTL1 "RTN","RARTE4",59,0) ASKREP W !!,"Do you want to place this report in the batch ",RABTCHN,"? Yes// " R X:DTIME S:'$T!(X["^") X="N" S:X="" X="Y" G PRT1:"Nn"[$E(X) "RTN","RARTE4",60,0) I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to place this report in the batch, or 'NO' not to." G ASKREP "RTN","RARTE4",61,0) I $D(^RABTCH(74.2,"D",RARPT,RABTCH)) W !?5,"...report is already part of the '",RABTCHN,"' batch" D INCRPT G START^RARTE "RTN","RARTE4",62,0) W !?5,"...will now place report in the '",RABTCHN,"' batch" S DIE="^RABTCH(74.2,",DA=RABTCH,DR="25///"_$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN,DR(2,74.21)="2////N" D ^DIE K DQ,DE D INCRPT G START^RARTE "RTN","RARTE4",63,0) PRT1 R !!,"Do you wish to print this report? No// ",X:DTIME S:'$T!(X["^") X="N" S:X="" X="N" ;030497 "RTN","RARTE4",64,0) I "Nn"[$E(X) D INCRPT G START^RARTE "RTN","RARTE4",65,0) I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to print this report, or 'NO' not to." G PRT1 "RTN","RARTE4",66,0) S ION=$P(RAMLC,"^",10),IOP=$S(ION]"":"Q;"_ION,1:"Q") "RTN","RARTE4",67,0) S RAMES="W !!?3,""Report has been queued for printing on device "",ION,"".""" "RTN","RARTE4",68,0) D Q^RARTR D INCRPT G START^RARTE "RTN","RARTE4",69,0) ; "RTN","RARTE4",70,0) Q I $D(RABTCH),$D(^RABTCH(74.2,+RABTCH,"R",0)) D ASKPRT^RARTE1,BTCH^RABTCH:"Yy"[$E(X) "RTN","RARTE4",71,0) Q1 K %,%DT,%W,%Y,%Y1,C,D0,D1,DA,DIC,DIE,DR,OREND,RABTCH,RABTCHN,RACN,RACNI,RACOPY,RACS,RACT,RADATE,RADFN,RADTE,RADTI,RADUZ,RAELESIG,RAFIN,RAHEAD,RAI,RAJ1 "RTN","RARTE4",72,0) K RALI,RALR,RANME,RANUM,RAOR,RAORDIFN,RAPNODE,RAPRC,RAPRIT,RAQUIT,RAREPORT,RARES,RARPDT,RARPT,RARPTN,RARPTZ,RARTPN,RASET,RASI,RASIG,RASN,RASSN,RAST,RAST1,RASTI,RASTFF,RAVW,XQUIT,W,X,Y "RTN","RARTE4",73,0) K D,D2,DDER,DI,DIPGM,DLAYGO,J,RAEND,RAF5,RAFL,RAFST,RAIX,RAPOP,RAY1 "RTN","RARTE4",74,0) K ^TMP($J,"RAEX") "RTN","RARTE4",75,0) K POP,DUOUT "RTN","RARTE4",76,0) Q "RTN","RARTE4",77,0) DICW ; Build DIC("W") string "RTN","RARTE4",78,0) N DO D DO^DIC1 "RTN","RARTE4",79,0) S DIC("W")=$S($G(DIC("W"))]"":DIC("W")_" ",1:"")_"W "" "",$$FLD^RARTFLDS(+Y,""PROC"")" "RTN","RARTE4",80,0) Q "RTN","RARTE4",81,0) INCRPT ; Kill extraneous variables to avoid collisions. "RTN","RARTE4",82,0) ; Incomplete report information, select another case #. "RTN","RARTE4",83,0) K %,%DT,D,D0,D1,D2,DI,DIC,DIWT,DN,I,J,RACN,RACNI,RACT,RADATE,RADTE "RTN","RARTE4",84,0) K RADTI,RAFIN,RAI,RALI,RALR,RANME,RAPRC,RARPT,RARPTN,RASSN,RAST,RAVW,X "RTN","RARTE4",85,0) Q "RTN","RARTE4",86,0) UNLOCK2 D UNLOCK^RAUTL12(RAPNODE,RACNI) L -^RADPT(RADFN,"DT",RADTI) "RTN","RARTE4",87,0) Q "RTN","RARTE5") 0^52^B102640298 "RTN","RARTE5",1,0) RARTE5 ;HISC/SWM AISC/MJK,RMO-Enter/Edit Outside Reports ;1/26/09 11:36 "RTN","RARTE5",2,0) ;;5.0;Radiology/Nuclear Medicine;**56,95,97,47**;Mar 16, 1998;Build 21 "RTN","RARTE5",3,0) ;Private IA #4793 CREATE^WVRALINK "RTN","RARTE5",4,0) ;Controlled IA #3544 ^VA(200 "RTN","RARTE5",5,0) ;Supported IA #2056 GET1^DIQ "RTN","RARTE5",6,0) ;Supported IA #10013 IX1^DIK "RTN","RARTE5",7,0) ;Supported IA #10141 MES^XPDUTL "RTN","RARTE5",8,0) ; adapted from RARTE, RARTE1, RARTE4 "RTN","RARTE5",9,0) F I=1:1:10 W !?3,$P($T(INTRO+I),";;",2) "RTN","RARTE5",10,0) W ! D SET^RAPSET1 I $D(XQUIT) K XQUIT Q "RTN","RARTE5",11,0) N RAXIT,RASUBY0,RA18EX,RAPRTSET,RAMEMARR,RA1,RA7003 "RTN","RARTE5",12,0) S RAXIT=0 "RTN","RARTE5",13,0) K RASSS,RASSSX ;clear HL7 exclusion vars "RTN","RARTE5",14,0) I $D(RANOSCRN) S X=$$DIVLOC^RAUTL7() I X D Q1 QUIT "RTN","RARTE5",15,0) ; "RTN","RARTE5",16,0) ; only require any Radiology Classification in New Person file "RTN","RARTE5",17,0) S X=0 F I="C","R","S","T" S:$D(^VA(200,"ARC",I,DUZ)) X=1 "RTN","RARTE5",18,0) I 'X W !,"Your user account is missing a Radiology classification.",! D INCRPT Q "RTN","RARTE5",19,0) ; "RTN","RARTE5",20,0) START S RAFIRST=0 ;=1 for 1st time rpt given "EF" rpt status "RTN","RARTE5",21,0) K RAVER S RAVW="",RAREPORT=1 D ^RACNLU G Q1:"^"[X "RTN","RARTE5",22,0) ; RACNLU defines RADFN, RADTI, RACNI, RARPT "RTN","RARTE5",23,0) S RASUBY0=Y(0) ; save value of y(0) "RTN","RARTE5",24,0) N RASSAN,RACNDSP S RASSAN=$P(RASUBY0,U,31) "RTN","RARTE5",25,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:$P(RASUBY0,U,1)) "RTN","RARTE5",26,0) G:$P(^RA(72,+RAST,0),"^",3)>0 CONTIN "RTN","RARTE5",27,0) I $D(^XUSEC("RA MGR",DUZ)) G CONTIN "RTN","RARTE5",28,0) G:$P(RAMDV,"^",22)=1 CONTIN "RTN","RARTE5",29,0) W $C(7),!!,"The STATUS for this case is CANCELLED. You may not enter a report.",!! D INCRPT G START "RTN","RARTE5",30,0) ; "RTN","RARTE5",31,0) CONTIN ; continue "RTN","RARTE5",32,0) S RAXIT=0 D DISPLAY^RARTE6 "RTN","RARTE5",33,0) I RA18EX=-1 D INCRPT G START "RTN","RARTE5",34,0) ; raprtset is defined in display^rarte6 "RTN","RARTE5",35,0) S RAPNODE="^RADPT("_RADFN_",""DT"","_RADTI_",""P""," "RTN","RARTE5",36,0) S RA7003=@(RAPNODE_RACNI_",0)") "RTN","RARTE5",37,0) S RAXIT=$$LOCK^RARTE6(RAPNODE,RACNI) I RAXIT D INCRPT G START "RTN","RARTE5",38,0) ; "RTN","RARTE5",39,0) ; Real rpt must have fld 5="EF" & fld 18 w/ data. Stub rpt allowed "RTN","RARTE5",40,0) I $D(^RARPT(+RARPT,0)),(($P(^(0),"^",5)'="EF")!($P(^(0),"^",18)="")),'$$STUB^RAEDCN1(+RARPT) W !?3,$C(7),"Only Electronically Filed reports can be selected!",! D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT G START "RTN","RARTE5",41,0) ;Create new rpt, or skip to IN to edit existing report "RTN","RARTE5",42,0) G IN:$D(^RARPT(+RARPT,0)) "RTN","RARTE5",43,0) ; "RTN","RARTE5",44,0) G:'RAPRTSET NEW G:$P(^RA(72,+RAST,0),"^",3)>0 NEW "RTN","RARTE5",45,0) ; case is part of a print set, AND is cancelled "RTN","RARTE5",46,0) N RA2 S (RA1,RA2)="" "RTN","RARTE5",47,0) F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" S:$P(RAMEMARR(RA1),"^",3)]"" RA2=$P(RAMEMARR(RA1),"^",3) "RTN","RARTE5",48,0) G:RA2="" NEW "RTN","RARTE5",49,0) W !!,$C(7),"Other cases of this cancelled case ",RACN,"'s print set are entered in a report already",!!,"You may NOT create a new report for this cancelled case,",!,"but you may include this cancelled case in the existing report." "RTN","RARTE5",50,0) W !!,"Do you want to include this cancelled case in the same report",!,"as the others in the print set ?" "RTN","RARTE5",51,0) S %=2 D YN^DICN "RTN","RARTE5",52,0) W:%>0 "...",$S(%=1:"Include",1:"Skip")," this case" "RTN","RARTE5",53,0) I %=1 S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=RA2,RARPT=RA2,RARPTN=$P(^RARPT(RARPT,0),"^"),RA1=RACN D INSERT^RARTE2 "RTN","RARTE5",54,0) D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT G START "RTN","RARTE5",55,0) NEW G:'RAPRTSET NEW1 "RTN","RARTE5",56,0) L +^RADPT(RADFN,"DT",RADTI):DILOCKTM G:$T NEW1 "RTN","RARTE5",57,0) W !!?10,$C(7),"** This case belongs to a printset, and someone else is",?68,"**",!?10,"** editing another case from this printset, or entering",?68,"**" "RTN","RARTE5",58,0) W !?10,"** a report for this printset, so you may not enter a",?68,"**",!?10,"** new report.",?68,"**" "RTN","RARTE5",59,0) H 2 D UNLOCK^RAUTL12(RAPNODE,RACNI) D INCRPT G START "RTN","RARTE5",60,0) ; "RTN","RARTE5",61,0) NEW1 ; "RTN","RARTE5",62,0) I $L(RACNDSP,"-")>1 S RARPTN=RACNDSP "RTN","RARTE5",63,0) I $L(RACNDSP,"-")<2 S RARPTN=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN "RTN","RARTE5",64,0) W !?3,"...report not entered for this exam...",!?10,"...will now initialize report entry..." "RTN","RARTE5",65,0) S I=+$P(^RARPT(0),"^",3) "RTN","RARTE5",66,0) ; "RTN","RARTE5",67,0) LOCK ;Try to lock next avail IEN, if locked - fail, if used - increment again "RTN","RARTE5",68,0) S I=I+1 S RAXIT=$$LOCK^RARTE6("^RARPT(",I) I RAXIT D UNLOCK2^RARTE4 D INCRPT G START "RTN","RARTE5",69,0) ;don't check ^RARPT("B",RARPTN) due cloaked deleted reports "RTN","RARTE5",70,0) I $D(^RARPT(I)) D UNLOCK^RAUTL12("^RARPT(",I) G LOCK "RTN","RARTE5",71,0) S ^RARPT(I,0)=RARPTN,RARPT=I,^(0)=$P(^RARPT(0),"^",1,2)_"^"_I_"^"_($P(^(0),"^",4)+1),^DISV($S($D(DUZ)#2:DUZ,1:0),"^RARPT(")=I S:'$D(^RARPT(RARPT,"T")) ^("T")="" "RTN","RARTE5",72,0) S ^RARPT(RARPT,0)=RARPTN_"^"_RADFN_"^"_RADTE_"^"_RACN_"^EF",DIK="^RARPT(",DA=RARPT D IX1^DIK "RTN","RARTE5",73,0) K %,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y "RTN","RARTE5",74,0) S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI "RTN","RARTE5",75,0) S DIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P""," "RTN","RARTE5",76,0) S DR="17////"_RARPT D ^DIE "RTN","RARTE5",77,0) K %,D,D0,DA,DI,DIC,DIE,DQ,DR,RAY1,X,Y "RTN","RARTE5",78,0) ;if printset -- set pc 17 in subfile 70.03 and subrec in subfile 74.05 "RTN","RARTE5",79,0) I RAPRTSET D PTR^RARTE2 "RTN","RARTE5",80,0) I RAXIT D UNLOCK2^RARTE4,UNLOCK^RAUTL12("^RARPT(",RARPT) G Q1 "RTN","RARTE5",81,0) W !,RAI "RTN","RARTE5",82,0) G IN0 "RTN","RARTE5",83,0) IN ;edit existing rpt, so lock rpt fr the 1st time "RTN","RARTE5",84,0) S RAXIT=$$LOCK^RARTE6("^RARPT(",RARPT) I RAXIT D UNLOCK2^RARTE4 G Q1 "RTN","RARTE5",85,0) IN0 ;skip to here if rpt created in this session and already locked "RTN","RARTE5",86,0) ; Flag first time EF report is made if piece 18 has no data yet "RTN","RARTE5",87,0) I $P(^RARPT(RARPT,0),U,18)="" S RAFIRST=1 "RTN","RARTE5",88,0) ; save DXs before edit "RTN","RARTE5",89,0) S RANY1=$$ANYDX^RARTE7(.RAA1) ;1=has DXs, 0=no DXs, RAA1() stores DXs "RTN","RARTE5",90,0) ; Ask if copy standard report "RTN","RARTE5",91,0) I $P(RAMDV,"^",12) D STD^RARTE1 I X="^" S RAXIT=1 G UNCASE "RTN","RARTE5",92,0) ; Ask Report Date "RTN","RARTE5",93,0) S DR="8",DA=RARPT,DIE="^RARPT(" D ^DIE K DE,DQ "RTN","RARTE5",94,0) ; y is defined if user "^" out "RTN","RARTE5",95,0) I $D(Y) K Y G UNCASE "RTN","RARTE5",96,0) ; Display Clinical History "RTN","RARTE5",97,0) D CHPRINT^RAUTL9 "RTN","RARTE5",98,0) ; report status before editing "RTN","RARTE5",99,0) S RACT=$P(^RARPT(RARPT,0),U,5) "RTN","RARTE5",100,0) ; Edit Report Text and enter Diagnostic code(s) "RTN","RARTE5",101,0) D ERPT "RTN","RARTE5",102,0) ; Resident and Staff not asked and not copied to other cases of printset "RTN","RARTE5",103,0) ; continue to check sufficient data even if RAXIT=1 at this point "RTN","RARTE5",104,0) UNCASE ; "RTN","RARTE5",105,0) D UNLOCK^RAUTL12(RAPNODE,RACNI) ;unlock case "RTN","RARTE5",106,0) ; copy diags to other cases of printset "RTN","RARTE5",107,0) ; and unlock case "DT" level after copying is done "RTN","RARTE5",108,0) I RAPRTSET S RADRS=1,RAXIT=0 D COPY^RARTE2 L -^RADPT(RADFN,"DT",RADTI) "RTN","RARTE5",109,0) ; first time EF rpt made -- del rpt & xrefs if no rpt txt & impression "RTN","RARTE5",110,0) I RAFIRST S RAXIT=$$CCAN(RARPT) "RTN","RARTE5",111,0) D UNLOCK^RAUTL12("^RARPT(",RARPT) ;unlock report "RTN","RARTE5",112,0) G:RAXIT PRT "RTN","RARTE5",113,0) ; "RTN","RARTE5",114,0) ; "EF" was stuffed in LOCK+5 for new rpts but not stub rpt yet "RTN","RARTE5",115,0) I $P(^RARPT(RARPT,0),U,5)'="EF" D SETFF^RARTE6(74,5,RARPT,"EF") "RTN","RARTE5",116,0) W !!?5,"Report status is stored as ""Electronically Filed""." "RTN","RARTE5",117,0) ; Stuff in initial entry date only once "RTN","RARTE5",118,0) I RAFIRST D SETFF^RARTE6(74,18,RARPT,"NOW","E") "RTN","RARTE5",119,0) ; Stuff in Activity Log subfile at all times "RTN","RARTE5",120,0) D SETALOG^RARTE6("+1,"_RARPT_",","F","") "RTN","RARTE5",121,0) ; "RTN","RARTE5",122,0) ; transmit to women's health each time this point is reached "RTN","RARTE5",123,0) ; COPY^WVRALINK will stop if the same case number is already in 790.1 "RTN","RARTE5",124,0) ; "RTN","RARTE5",125,0) I $P(^RARPT(RARPT,0),U,5)="EF",$T(CREATE^WVRALINK)]"" D CREATE^WVRALINK(RADFN,RADTI,RACNI) ; women's health "RTN","RARTE5",126,0) ; "RTN","RARTE5",127,0) PRT I RAXIT S RAXIT=0 D UNLOCK2^RARTE4 D INCRPT G START "RTN","RARTE5",128,0) ; "RTN","RARTE5",129,0) ; report status after editing "RTN","RARTE5",130,0) S RACT=$P(^RARPT(RARPT,0),U,5) "RTN","RARTE5",131,0) ; --- "RTN","RARTE5",132,0) ; set RAHLTCPB to prevent broadcast ORM messages "RTN","RARTE5",133,0) N RAHLTCPB S RAHLTCPB=1 "RTN","RARTE5",134,0) ; "RTN","RARTE5",135,0) ; update case's exam status only if exam status isn't COMPLETE "RTN","RARTE5",136,0) ; and isn't CANCEL "RTN","RARTE5",137,0) ; and ((birads not required) or (birads required and entered)) "RTN","RARTE5",138,0) S RA2=$$GET1^DIQ(72,+$P(RA7003,U,3)_",",3) "RTN","RARTE5",139,0) I RA2'=9,(RA2'=0) D "RTN","RARTE5",140,0) .I 'RABIREQ D UP1^RAUTL1 Q "RTN","RARTE5",141,0) .I RABIDAT D UP1^RAUTL1 Q "RTN","RARTE5",142,0) .E W !!?5,"Exam status not recalculated due to missing BI-RADS code." "RTN","RARTE5",143,0) .Q "RTN","RARTE5",144,0) S RANY2=$$ANYDX^RARTE7(.RAA2) ;RAA2() store DXs after edit "RTN","RARTE5",145,0) ; check if new/changed diagnostic codes, send alert if nec. "RTN","RARTE5",146,0) D ALERT^RARTE7 "RTN","RARTE5",147,0) K RAAB "RTN","RARTE5",148,0) ; broadcast if EF rpt made first time, or any DX changed/added/del'd "RTN","RARTE5",149,0) I $O(RAA2(0))!(RAFIRST) D "RTN","RARTE5",150,0) .D HLXMSG ;find VR subscribers to exclude "RTN","RARTE5",151,0) .D RPT^RAHLRPC "RTN","RARTE5",152,0) .Q "RTN","RARTE5",153,0) PRT1 R !!,"Do you wish to print this report? No// ",X:DTIME S:'$T!(X["^") X="N" S:X="" X="N" ;030497 "RTN","RARTE5",154,0) I "Nn"[$E(X) D INCRPT G START "RTN","RARTE5",155,0) I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to print this report, or 'NO' not to." G PRT1 "RTN","RARTE5",156,0) S ION=$P(RAMLC,"^",10),IOP=$S(ION]"":"Q;"_ION,1:"Q") "RTN","RARTE5",157,0) S RAMES="W !!?3,""Report has been queued for printing on device "",ION,"".""" "RTN","RARTE5",158,0) D Q^RARTR D INCRPT G START ; queue rpt, cleanup, startover "RTN","RARTE5",159,0) ; "RTN","RARTE5",160,0) Q1 K %,%DT,%W,%Y,%Y1,C,D0,D1,DA,DIC,DIE,DR,OREND,RABTCH,RABTCHN,RACN,RACNI,RACOPY,RACS,RACT,RADATE,RADFN,RADTE,RADTI,RADUZ,RAELESIG,RAFIN,RAHEAD,RAI,RAJ1 "RTN","RARTE5",161,0) K RALI,RALR,RANME,RANUM,RAOR,RAORDIFN,RAPNODE,RAPRC,RAPRIT,RAQUIT,RAREPORT,RARES,RARPDT,RARPT,RARPTN,RARPTZ,RARTPN,RASET,RASI,RASIG,RASN,RASSN,RAST,RAST1,RASTI,RASTFF,RAVW,XQUIT,W,X,Y "RTN","RARTE5",162,0) K D,D2,DDER,DI,DIPGM,DLAYGO,J,RAEND,RAF5,RAFL,RAFST,RAIX,RAPOP,RAY1 "RTN","RARTE5",163,0) K ^TMP($J,"RAEX") "RTN","RARTE5",164,0) K POP,DUOUT,RAFDA,RATEXT,RADIR0,RAXIT "RTN","RARTE5",165,0) D INCRPT "RTN","RARTE5",166,0) Q "RTN","RARTE5",167,0) INCRPT ; Kill extraneous variables to avoid collisions. "RTN","RARTE5",168,0) ; Incomplete report information, select another case #. "RTN","RARTE5",169,0) K DA,DIE,DR,RATXT "RTN","RARTE5",170,0) K %,%DT,D,D0,D1,D2,DI,DIC,DIWT,DN,I,J,RAA1,RAA2 "RTN","RARTE5",171,0) K RABIENS,RABIDAT,RABIREQ,RACN,RACNI,RACT "RTN","RARTE5",172,0) K RADATE,RADRS,RADTE,RADTI,RAFIN,RAFIRST,RAI,RALI,RALR,RANME,RAPRC,RARPT "RTN","RARTE5",173,0) K RARPTN,RASSN,RAST,RAVW,RASSS,RASSSX,X "RTN","RARTE5",174,0) Q "RTN","RARTE5",175,0) CCAN(IEN74) ;Check canned report for Outside Reporting "RTN","RARTE5",176,0) ; adapted from EN3^RAUTL15 "RTN","RARTE5",177,0) ; outputs: 0 if report is kept "RTN","RARTE5",178,0) ; 1 if report is deleted due to no canned text entered "RTN","RARTE5",179,0) ; "RTN","RARTE5",180,0) N RAPRG74,RATXT "RTN","RARTE5",181,0) ; keep report if it is linked to images "RTN","RARTE5",182,0) I $O(^RARPT(IEN74,2005,0))>0 Q 0 "RTN","RARTE5",183,0) ; "RTN","RARTE5",184,0) ;del canned report if missing both REPORT TEXT and IMPRESSION TEXT "RTN","RARTE5",185,0) I '$O(^RARPT(IEN74,"I",0)),'$O(^RARPT(IEN74,"R",0)) D Q 1 "RTN","RARTE5",186,0) .; un-link rpt from other cases of printset "RTN","RARTE5",187,0) .D DEL17^RARTE2(IEN74) "RTN","RARTE5",188,0) .; exec field's xrefs' KILL logic "RTN","RARTE5",189,0) .S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI "RTN","RARTE5",190,0) .D ENKILL^RAXREF(70.03,17,IEN74,.DA) "RTN","RARTE5",191,0) .; "RTN","RARTE5",192,0) .;del piece 17 from case record "RTN","RARTE5",193,0) .S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)="" K DA,X "RTN","RARTE5",194,0) .; "RTN","RARTE5",195,0) .; Del report ptr from batch and distribution files "RTN","RARTE5",196,0) .D UPDTPNT^RAUTL9(IEN74) "RTN","RARTE5",197,0) .; "RTN","RARTE5",198,0) .; Del entry from Report file "RTN","RARTE5",199,0) .S DA=IEN74,DIK="^RARPT(" D ^DIK "RTN","RARTE5",200,0) .S RATXT(1)=" " "RTN","RARTE5",201,0) .S RATXT(2)=" Outside canned report not complete. Must Delete......deletion complete!" "RTN","RARTE5",202,0) .S RATXT(3)=$C(7) D MES^XPDUTL(.RATXT) "RTN","RARTE5",203,0) .; also delete any diagnostic codes from case record "RTN","RARTE5",204,0) .I RAPRTSET D DELDXPRT ;del DXs from printset cases "RTN","RARTE5",205,0) .I 'RAPRTSET D DELDX ;del DXs from standalone case "RTN","RARTE5",206,0) .Q "RTN","RARTE5",207,0) Q 0 "RTN","RARTE5",208,0) ERPT ; Edit report text, impression, and enter/edit diagnostic codes "RTN","RARTE5",209,0) ;remove lock case commands here since case is still locked "RTN","RARTE5",210,0) S $P(RATXT,"+",52)="" "RTN","RARTE5",211,0) W !!?5,RATXT,!?8,"Required: REPORT TEXT and/or IMPRESSION TEXT",!?5,RATXT "RTN","RARTE5",212,0) S RAXIT=0 ; here, =1 means user "^" out "RTN","RARTE5",213,0) S DA=RARPT,DIE="^RARPT(" "RTN","RARTE5",214,0) S DR="200;I X=""^"" S Y=""@8"";300;I X'=""^"" S Y=""@9"";@8;S RAXIT=1;@9" "RTN","RARTE5",215,0) D ^DIE "RTN","RARTE5",216,0) ; subseq edit -- Report Text and Impression Text cannot both be empty "RTN","RARTE5",217,0) I 'RAFIRST,'$O(^RARPT(RARPT,"I",0)),'$O(^RARPT(RARPT,"R",0)) G ERPT "RTN","RARTE5",218,0) ; dont quit on "^" if mammography study "RTN","RARTE5",219,0) D CKREQ^RABIRAD ;check if BIRADS diag is required "RTN","RARTE5",220,0) I RAXIT=1,'RABIREQ Q "RTN","RARTE5",221,0) DIAG ; Diagnostic codes "RTN","RARTE5",222,0) ; (code taken from routine RARTE1) "RTN","RARTE5",223,0) S RAIMGTYI=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2),RAIMGTYJ=$P($G(^RA(79.2,+RAIMGTYI,0)),U) "RTN","RARTE5",224,0) S X=+$O(^RA(72,"AA",RAIMGTYJ,9,0)),DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," K RAIMGTYI,RAIMGTYJ "RTN","RARTE5",225,0) ; ask Prim. Diag, required if site require diag, don't ck abnormal here "RTN","RARTE5",226,0) S DR=13_$S('$D(^RA(72,X,.1)):"",$P(^(.1),"^",5)'="Y":"",1:"R") "RTN","RARTE5",227,0) ; allow user to "^" exit "RTN","RARTE5",228,0) D ^DIE K DA,DE,DQ,DIE,DR "RTN","RARTE5",229,0) I ($P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,13)="")!($D(Y)) S RAXIT=0 G PACS "RTN","RARTE5",230,0) S DR="50///"_RACN "RTN","RARTE5",231,0) S DR(2,70.03)=13.1 "RTN","RARTE5",232,0) S DR(3,70.14)=.01 ; don't ck abnormal here "RTN","RARTE5",233,0) S DA(1)=RADFN,DA=RADTI,DIE="^RADPT("_DA(1)_",""DT""," "RTN","RARTE5",234,0) D ^DIE K DA,DE,DQ,DIE,DR "RTN","RARTE5",235,0) I $D(Y) K Y S RAXIT=1 ;$D(Y) means user "^" out "RTN","RARTE5",236,0) PACS ; do not broadcast ORU message at this point "RTN","RARTE5",237,0) ; "RTN","RARTE5",238,0) ; if BIRADS required, ck if BIRADS entered, if not, go back to ask diag "RTN","RARTE5",239,0) I RABIREQ D CKDATA^RABIRAD I 'RABIDAT I $$ASK^RABIRAD G DIAG "RTN","RARTE5",240,0) ; move WV outside of this in case rpt is deleted due insufficient data "RTN","RARTE5",241,0) Q "RTN","RARTE5",242,0) ; "RTN","RARTE5",243,0) HLXMSG ; set up RASSSX() of VR subscribers to exclude from ORM msg broadcast "RTN","RARTE5",244,0) N RA,XX "RTN","RARTE5",245,0) ; q if there are no HL applications that use the 4 RA HL7 protocols "RTN","RARTE5",246,0) Q:'$$GETAP^RAHLRS1(.XX) "RTN","RARTE5",247,0) S RA=$NA(XX) "RTN","RARTE5",248,0) F S RA=$Q(@RA) Q:RA="" I RA'["RA-TALK",(RA'["RA-PSCRIBE"),(RA'["RA-SCIMAGE"),(RA'["RA-RADWHERE") S RASSS(@RA)="" "RTN","RARTE5",249,0) ; RASSS(ien #771) "RTN","RARTE5",250,0) ; RASSSX(ien #101 driver, ien #101 subscriber)=".01 value of driver" "RTN","RARTE5",251,0) D:$D(RASSS)>1 GETSUB^RAHLRS1(.RASSS,.RASSSX) "RTN","RARTE5",252,0) Q "RTN","RARTE5",253,0) DELDX ; del any Prim. and Sec. DXs from standalone case "RTN","RARTE5",254,0) S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",13)="@" ;Prim DX "RTN","RARTE5",255,0) D FILE^DIE("","RAFDA") "RTN","RARTE5",256,0) K RAFDA "RTN","RARTE5",257,0) D KILSEC^RARTE7(70.14,RACNI) "RTN","RARTE5",258,0) Q "RTN","RARTE5",259,0) DELDXPRT ;del any Prim. and Sec. DXs from all cases in printset "RTN","RARTE5",260,0) S RA1=0 "RTN","RARTE5",261,0) F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" D "RTN","RARTE5",262,0) .S RAFDA(70.03,RA1_","_RADTI_","_RADFN_",",13)="@" ;Prim DX "RTN","RARTE5",263,0) .D FILE^DIE("","RAFDA") "RTN","RARTE5",264,0) .K RAFDA "RTN","RARTE5",265,0) .D KILSEC^RARTE7(70.14,RA1) "RTN","RARTE5",266,0) .Q "RTN","RARTE5",267,0) Q "RTN","RARTE5",268,0) INTRO ; "RTN","RARTE5",269,0) ;;+--------------------------------------------------------+ "RTN","RARTE5",270,0) ;;| | "RTN","RARTE5",271,0) ;;| This option is for entering canned text for | "RTN","RARTE5",272,0) ;;| outside work: interpreted report done outside, | "RTN","RARTE5",273,0) ;;| and images made outside this facility. | "RTN","RARTE5",274,0) ;;| | "RTN","RARTE5",275,0) ;;| For a printset, the canned text must apply to all | "RTN","RARTE5",276,0) ;;| cases within the printset. | "RTN","RARTE5",277,0) ;;| | "RTN","RARTE5",278,0) ;;+--------------------------------------------------------+ "RTN","RARTE6") 0^53^B140134431 "RTN","RARTE6",1,0) RARTE6 ;HISC/SM Restore deleted report ;03/01/10 13:44 "RTN","RARTE6",2,0) ;;5.0;Radiology/Nuclear Medicine;**56,95,99,47**;Mar 16, 1998;Build 21 "RTN","RARTE6",3,0) ;Supported IA #10060 ^VA(200 "RTN","RARTE6",4,0) ;Supported IA #2053 FILE^DIE, UPDATE^DIE "RTN","RARTE6",5,0) ;Supported IA #2052 GET1^DID "RTN","RARTE6",6,0) ;Supported IA #2056 GET1^DIQ "RTN","RARTE6",7,0) ;Supported IA #10103 NOW^XLFDT "RTN","RARTE6",8,0) ;Supported IA #2055 ROOT^DILFD "RTN","RARTE6",9,0) ;Supported IA #10060 GETS^DIQ "RTN","RARTE6",10,0) ;P99, added pregnancy screen and pregnancy screen comment "RTN","RARTE6",11,0) Q "RTN","RARTE6",12,0) RSTR ;restore deleted report "RTN","RARTE6",13,0) F I=1:1:5 W !?4,$P($T(INTRO+I),";;",2) "RTN","RARTE6",14,0) W ! "RTN","RARTE6",15,0) S RAXIT=0 ; =0 exit normally, =1 exit early "RTN","RARTE6",16,0) I '$D(^XUSEC("RA MGR",DUZ)) W !!,"Supervisory key RA MGR is needed for this option." Q "RTN","RARTE6",17,0) S DIC("S")="I $P(^(0),""^"",5)=""X""" ;only select deleted reports "RTN","RARTE6",18,0) S DIC("A")="Select Deleted Report to restore: " "RTN","RARTE6",19,0) S DIC="^RARPT(",DIC(0)="AEMQZ" "RTN","RARTE6",20,0) D DICW^RARTST1,^DIC K DIC I Y<0 G FINISH "RTN","RARTE6",21,0) S RARPT=+Y "RTN","RARTE6",22,0) W ! "RTN","RARTE6",23,0) D CHECK G:RAXIT NOTDONE ;check if case has rpt & DX codes "RTN","RARTE6",24,0) D ASK1 G:RAXIT NOTDONE ;ask if want restore deleted report "RTN","RARTE6",25,0) D ASSOC G:RAXIT NOTDONE ;display associated case(s) & ask user again if want continue "RTN","RARTE6",26,0) D RESTORE ;restore rpt status, link rpt to case(s) "RTN","RARTE6",27,0) D FINISH "RTN","RARTE6",28,0) Q "RTN","RARTE6",29,0) CHECK ; check if associated case(s) has rpt and DX codes "RTN","RARTE6",30,0) S RA74=^RARPT(RARPT,0) "RTN","RARTE6",31,0) S RADFN=+$P(RA74,U,2),RADTI=9999999.9999-$P(RA74,U,3),RACN=+$P($P(RA74,U,1),"-",$L($P(RA74,U,1),"-")) "RTN","RARTE6",32,0) S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) "RTN","RARTE6",33,0) S RA70=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) "RTN","RARTE6",34,0) I 'RADFN!('RADTI)!('RACNI)!(RA70="") D ERR0 Q "RTN","RARTE6",35,0) S RANME=$$GET1^DIQ(2,RADFN,.01),RAST=+$P(RA70,U,3) "RTN","RARTE6",36,0) S RAPRC=$S($D(^RAMIS(71,+$P(RA70,U,2),0)):$P(^(0),U),1:"Unknown") "RTN","RARTE6",37,0) S RASSN=$$SSN^RAUTL,RASUBY0=RA70 "RTN","RARTE6",38,0) S RANODE=$G(^RADPT(RADFN,"DT",RADTI,0)) "RTN","RARTE6",39,0) ; check if case(s) already have a report "RTN","RARTE6",40,0) D EN2^RAUTL20(.RAMEMARR) "RTN","RARTE6",41,0) I RAPRTSET D "RTN","RARTE6",42,0) .S RA1=0 "RTN","RARTE6",43,0) .F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" D "RTN","RARTE6",44,0) ..I $P(^RADPT(RADFN,"DT",RADTI,"P",RA1,0),U,17)'="" D ERR3($P(RAMEMARR(RA1),"^")) "RTN","RARTE6",45,0) ..Q "RTN","RARTE6",46,0) .Q "RTN","RARTE6",47,0) E I $P(RA70,U,17) D ERR3($P(RA74,U,1)) Q "RTN","RARTE6",48,0) ; check if case(s) already have DX codes, staff, resident "RTN","RARTE6",49,0) ; don't use IF ELSE here due to outside calls "RTN","RARTE6",50,0) ; "RTN","RARTE6",51,0) ; Printset cases "RTN","RARTE6",52,0) I RAPRTSET D Q "RTN","RARTE6",53,0) .S RA1=0 "RTN","RARTE6",54,0) .F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" D "RTN","RARTE6",55,0) ..; check primary "RTN","RARTE6",56,0) ..F RA2=13,15,12 I $P(^RADPT(RADFN,"DT",RADTI,"P",RA1,0),U,RA2)'="" D ERR2($P(RAMEMARR(RA1),"^"),70.03,RA2) "RTN","RARTE6",57,0) ..; check secondary "RTN","RARTE6",58,0) ..S RAIENS=1_","_RA1_","_RADTI_","_RADFN_"," "RTN","RARTE6",59,0) ..F RA2=70.14,70.11,70.09 S RAROOT=$$ROOT^DILFD(RA2,RAIENS) I $O(@(RAROOT_"0)")) D ERR2($P(RAMEMARR(RA1),"^"),RA2,.01) "RTN","RARTE6",60,0) ..Q "RTN","RARTE6",61,0) .Q "RTN","RARTE6",62,0) ; single case "RTN","RARTE6",63,0) F RA2=13,15,12 I $P(RA70,U,RA2) D ERR2($P(RA74,U,1),70.03,RA2) "RTN","RARTE6",64,0) S RAIENS=1_","_RACNI_","_RADTI_","_RADFN_"," "RTN","RARTE6",65,0) F RA2=70.14,70.11,70.09 S RAROOT=$$ROOT^DILFD(RA2,RAIENS) I $O(@(RAROOT_"0)")) D ERR2($P(RA74,U,1),RA2,.01) "RTN","RARTE6",66,0) Q "RTN","RARTE6",67,0) ASK1 ; ask if want to restore report "RTN","RARTE6",68,0) ; RAPRVIEN last Activity Log rec in subfile 74.01 "RTN","RARTE6",69,0) ; RAPRVST previous report status logged in latest activity log rec "RTN","RARTE6",70,0) ; RALAST last activity log record "RTN","RARTE6",71,0) S RAPRVIEN=$O(^RARPT(RARPT,"L",""),-1) "RTN","RARTE6",72,0) I 'RAPRVIEN D ERR1 Q "RTN","RARTE6",73,0) S RALAST=$G(^RARPT(RARPT,"L",+RAPRVIEN,0)) "RTN","RARTE6",74,0) I RALAST="" D ERR1 Q "RTN","RARTE6",75,0) S RAPRVST=$P(RALAST,U,4) ;previous rpt status "RTN","RARTE6",76,0) K DIR "RTN","RARTE6",77,0) S DIR(0)="Y",DIR("B")="NO" "RTN","RARTE6",78,0) S DIR("A")="Do you want to restore this deleted report" "RTN","RARTE6",79,0) S DIR("?")="Answer ""Y"" to assign the previous report status, "_$$GET1^DIQ(74.01,RAPRVIEN_","_RARPT_",",4)_", to this report." "RTN","RARTE6",80,0) D ^DIR K DIR "RTN","RARTE6",81,0) S:$D(DIRUT) RAXIT=1 "RTN","RARTE6",82,0) S:'Y RAXIT=1 "RTN","RARTE6",83,0) Q "RTN","RARTE6",84,0) ASSOC ; "RTN","RARTE6",85,0) ; list case(s) for this report "RTN","RARTE6",86,0) S (Y,RADTE)=+$P(RANODE,U) "RTN","RARTE6",87,0) D D^RAUTL S RADATE=Y "RTN","RARTE6",88,0) D DISPLAY "RTN","RARTE6",89,0) W ! "RTN","RARTE6",90,0) K DIR "RTN","RARTE6",91,0) S DIR(0)="Y",DIR("B")="NO" "RTN","RARTE6",92,0) S DIR("A")="Are you sure you want to link this report back to the case"_$S(RAPRTSET:"s",1:"") "RTN","RARTE6",93,0) S DIR("?")="Answer ""Y"" to link this report back to the case(s) shown above." "RTN","RARTE6",94,0) D ^DIR K DIR "RTN","RARTE6",95,0) S:$D(DIRUT) RAXIT=1 "RTN","RARTE6",96,0) S:'Y RAXIT=1 "RTN","RARTE6",97,0) Q "RTN","RARTE6",98,0) RESTORE ; set Report Status to "before delete" value, link to case(s) "RTN","RARTE6",99,0) D SETFF(74,5,RARPT,RAPRVST) "RTN","RARTE6",100,0) W !!?3,"... Restored ",$P(RA74,U,1),"'s report status to: ",$$GET1^DIQ(74,+RARPT,5),"." "RTN","RARTE6",101,0) ; "RTN","RARTE6",102,0) ; set activity log record "RTN","RARTE6",103,0) S RAIENL="+1,"_RARPT_"," "RTN","RARTE6",104,0) D SETALOG(RAIENL,"R","") "RTN","RARTE6",105,0) ; "RTN","RARTE6",106,0) ; link report to single case or all cases of a printset "RTN","RARTE6",107,0) I RAPRTSET D "RTN","RARTE6",108,0) .S RA1="" "RTN","RARTE6",109,0) .F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" S $P(^RADPT(RADFN,"DT",RADTI,"P",RA1,0),U,17)=RARPT D MSG1($P(RAMEMARR(RA1),"^")) "RTN","RARTE6",110,0) .Q "RTN","RARTE6",111,0) E S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,17)=RARPT D MSG1($P(RA74,U,1)) "RTN","RARTE6",112,0) ; "RTN","RARTE6",113,0) ;Restore Primary and Secondary DX codes, Staff and Residents "RTN","RARTE6",114,0) ; "RTN","RARTE6",115,0) F RAFLD=5,7,9 S RAPREV=$P(RALAST,U,RAFLD) D:RAPREV SET70(RAFLD) "RTN","RARTE6",116,0) W !!!?3,"** You need to edit the case"_$S(RAPRTSET:"s",1:"")_" to update the exam status. **" "RTN","RARTE6",117,0) Q "RTN","RARTE6",118,0) SET70(X) ; put back previous DX codes, Staff, Residents into case record "RTN","RARTE6",119,0) ; assumes if no primary then no secondaries "RTN","RARTE6",120,0) K RAFDA,RAA "RTN","RARTE6",121,0) N RA1 "RTN","RARTE6",122,0) S RAIENS=1_","_RAPRVIEN_","_RARPT_"," "RTN","RARTE6",123,0) ; "RTN","RARTE6",124,0) ; X is the field number from subfile 74.01: "RTN","RARTE6",125,0) ; 5 = BEFORE DELETION PRIM. DX CODE "RTN","RARTE6",126,0) ; 7 = BEFORE DELETION PRIM. STAFF "RTN","RARTE6",127,0) ; 9 = BEFORE DELETION PRIM. RESIDENT "RTN","RARTE6",128,0) ; "RTN","RARTE6",129,0) ; RAF1 = subfile number from file 74's activity log "RTN","RARTE6",130,0) ; RAF2 = subfile number from file 70's secondaries "RTN","RARTE6",131,0) ; RAF3 = subfile number pointed to from file 70's secondaries "RTN","RARTE6",132,0) ; RAPIECE = piece in 70.03's 0 node "RTN","RARTE6",133,0) S RAF1=$S(X=5:74.16,X=7:74.18,X=9:74.19,1:"") Q:RAF1="" "RTN","RARTE6",134,0) S RAF2=$S(X=5:70.14,X=7:70.11,X=9:70.09,1:"") Q:RAF2="" "RTN","RARTE6",135,0) S RAF3=$$GET1^DID(RAF2,.01,"","POINTER") "RTN","RARTE6",136,0) ; extract file number from RAF3 "RTN","RARTE6",137,0) S RAF3=$TR(RAF3,$TR(RAF3,"0123456789.")) "RTN","RARTE6",138,0) ;piece number for Primary DX/Staff/Resident in 70.03 "RTN","RARTE6",139,0) S RAPIECE=$S(X=5:13,X=7:15,X=9:12,1:"") Q:RAPIECE="" "RTN","RARTE6",140,0) S RAROOT=$$ROOT^DILFD(RAF1,RAIENS,1) ;closed root under file 74's Activity Log "RTN","RARTE6",141,0) ;copy secondaries into RAA() "RTN","RARTE6",142,0) M RAA=@RAROOT "RTN","RARTE6",143,0) ; "RTN","RARTE6",144,0) G:RAPRTSET PSET "RTN","RARTE6",145,0) ; "RTN","RARTE6",146,0) ; single case "RTN","RARTE6",147,0) ; "RTN","RARTE6",148,0) ; copy Primary into single case "RTN","RARTE6",149,0) S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",RAPIECE)=RAPREV "RTN","RARTE6",150,0) D FILE^DIE("","RAFDA","RAMSG") "RTN","RARTE6",151,0) I $D(RAMSG("DIERR")) D ERR4($P(RA74,U,1),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01)) "RTN","RARTE6",152,0) E D MSG2($P(RA74,U,1),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01)) "RTN","RARTE6",153,0) K RAFDA,RAMSG "RTN","RARTE6",154,0) ; "RTN","RARTE6",155,0) Q:$O(RAA(0))'>0 ; no secondaries "RTN","RARTE6",156,0) ; "RTN","RARTE6",157,0) ;copy secondary items into single case "RTN","RARTE6",158,0) S RA1=0 "RTN","RARTE6",159,0) F S RA1=$O(RAA(RA1)) Q:'RA1 S RAX=$G(RAA(RA1,0)) D:RAX "RTN","RARTE6",160,0) .S RAFDA(RAF2,"+2,"_RACNI_","_RADTI_","_RADFN_",",.01)=RAX "RTN","RARTE6",161,0) .D UPDATE^DIE(,"RAFDA",,"RAMSG") "RTN","RARTE6",162,0) .I $D(RAMSG("DIERR")) D ERR4($P(RA74,U,1),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01)) "RTN","RARTE6",163,0) .E D MSG2($P(RA74,U,1),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01)) "RTN","RARTE6",164,0) .K RAFDA,RAMSG "RTN","RARTE6",165,0) .Q "RTN","RARTE6",166,0) Q "RTN","RARTE6",167,0) ; "RTN","RARTE6",168,0) ; cases from printset "RTN","RARTE6",169,0) ; "RTN","RARTE6",170,0) PSET ; copy Primary into cases of a printset "RTN","RARTE6",171,0) S RA1=0 "RTN","RARTE6",172,0) F S RA1=$O(RAMEMARR(RA1)) Q:RA1="" D "RTN","RARTE6",173,0) .S RAFDA(70.03,RA1_","_RADTI_","_RADFN_",",RAPIECE)=RAPREV "RTN","RARTE6",174,0) .D FILE^DIE("","RAFDA","RAMSG") "RTN","RARTE6",175,0) .I $D(RAMSG("DIERR")) D ERR4($P(RAMEMARR(RA1),"^"),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01)) "RTN","RARTE6",176,0) .;E D MSG2(+RAMEMARR(RA1),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01)) "RTN","RARTE6",177,0) .E D MSG2($P(RAMEMARR(RA1),"^"),$$GET1^DID(70.03,RAPIECE,"","LABEL"),$$GET1^DIQ(RAF3,RAPREV,.01)) "RTN","RARTE6",178,0) .K RAFDA,RAMSG "RTN","RARTE6",179,0) .Q:$O(RAA(0))'>0 ; no secondary DXs "RTN","RARTE6",180,0) .; copy secondaries into cases of a printset "RTN","RARTE6",181,0) .S RA2=0 "RTN","RARTE6",182,0) .F S RA2=$O(RAA(RA2)) Q:'RA2 S RAX=$G(RAA(RA2,0)) D:RAX "RTN","RARTE6",183,0) ..S RAFDA(RAF2,"+2,"_RA1_","_RADTI_","_RADFN_",",.01)=RAX "RTN","RARTE6",184,0) ..D UPDATE^DIE(,"RAFDA",,"RAMSG") "RTN","RARTE6",185,0) ..I $D(RAMSG("DIERR")) D ERR4($P(RAMEMARR(RA1),"^"),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01)) "RTN","RARTE6",186,0) ..;E D MSG2(+RAMEMARR(RA1),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01)) "RTN","RARTE6",187,0) ..E D MSG2($P(RAMEMARR(RA1),"^"),$$GET1^DID(RAF2,.01,"","LABEL"),$$GET1^DIQ(RAF3,RAX,.01)) "RTN","RARTE6",188,0) ..K RAFDA,RAMSG "RTN","RARTE6",189,0) ..Q "RTN","RARTE6",190,0) .Q "RTN","RARTE6",191,0) Q "RTN","RARTE6",192,0) SETFF(RA1,RA2,RA3,RA4,RA5) ;reset file's field value "RTN","RARTE6",193,0) ;RA1 file number "RTN","RARTE6",194,0) ;RA2 field number "RTN","RARTE6",195,0) ;RA3 IEN in file "RTN","RARTE6",196,0) ;RA4 field value to set in record IEN "RTN","RARTE6",197,0) ;RA5 (optional), set to "E" for external "RTN","RARTE6",198,0) N RAFDA "RTN","RARTE6",199,0) S RAFDA(RA1,RA3_",",RA2)=RA4 "RTN","RARTE6",200,0) I $G(RA5)="E" D FILE^DIE("E","RAFDA") "RTN","RARTE6",201,0) E D FILE^DIE("","RAFDA") "RTN","RARTE6",202,0) Q "RTN","RARTE6",203,0) SETALOG(RA1,RA2,RA3) ;set new record in Activity log 74.01 "RTN","RARTE6",204,0) ;RA1 ien string, eg., "+1,"_RARPT_"," "RTN","RARTE6",205,0) ;RA2 type of action "RTN","RARTE6",206,0) ;RA3 current report status code "RTN","RARTE6",207,0) ; "RTN","RARTE6",208,0) N RAFDA "RTN","RARTE6",209,0) S RAFDA(74.01,RA1,.01)=+$E($$NOW^XLFDT(),1,12) "RTN","RARTE6",210,0) S RAFDA(74.01,RA1,2)=RA2 "RTN","RARTE6",211,0) S RAFDA(74.01,RA1,3)=$G(DUZ) "RTN","RARTE6",212,0) S:$G(RA3)]"" RAFDA(74.01,RA1,4)=RA3 ;only del rpt would have data here "RTN","RARTE6",213,0) D UPDATE^DIE(,"RAFDA") "RTN","RARTE6",214,0) Q "RTN","RARTE6",215,0) MSG1(X) ; "RTN","RARTE6",216,0) W !?3,"... Linked restored report to case no. ",X "RTN","RARTE6",217,0) Q "RTN","RARTE6",218,0) MSG2(X,Y,Z) ; "RTN","RARTE6",219,0) W !?3,"... Restored case ",X,"'s ",Y," to: ",Z "RTN","RARTE6",220,0) Q "RTN","RARTE6",221,0) ERR0 ; "RTN","RARTE6",222,0) W !,"Unable to determine case previously associated with this report." "RTN","RARTE6",223,0) S RAXIT=1 "RTN","RARTE6",224,0) Q "RTN","RARTE6",225,0) ERR1 W !!,"Cannot determine previous report status.",! "RTN","RARTE6",226,0) S RAXIT=1 "RTN","RARTE6",227,0) Q "RTN","RARTE6",228,0) ERR2(X,Y,Z) ;X=External short case No, Y=File no., Z=Field no. "RTN","RARTE6",229,0) W !,"Case #",X," already has ",$$GET1^DID(Y,Z,"","LABEL") "RTN","RARTE6",230,0) S RAXIT=1 "RTN","RARTE6",231,0) Q "RTN","RARTE6",232,0) ERR3(X) ; "RTN","RARTE6",233,0) W !,"Case #",X," is already associated with a report!" "RTN","RARTE6",234,0) S RAXIT=1 "RTN","RARTE6",235,0) Q "RTN","RARTE6",236,0) ERR4(X,Y,Z) ; "RTN","RARTE6",237,0) W !!?3,"Cannot restore case ",X,"'s ",Y," to: ",Z "RTN","RARTE6",238,0) Q "RTN","RARTE6",239,0) NOTDONE ; "RTN","RARTE6",240,0) W !!?3,"Restoration was not done." "RTN","RARTE6",241,0) ; continue to clean up "RTN","RARTE6",242,0) FINISH ; clean up and exit "RTN","RARTE6",243,0) R !!!,"Press RETURN to exit. ",X:DTIME "RTN","RARTE6",244,0) K DIRUT,I "RTN","RARTE6",245,0) K RA1,RA2,RA3,RA4,RA5,RA18EX,RA70,RA74,RAA,RACMDATA "RTN","RARTE6",246,0) K RACN,RACNI,RADATE,RADFN,RADTE,RADTI,RADUZ,RAFDA,RAF1,RAF2,RAF3 "RTN","RARTE6",247,0) K RAI,RAIENL,RAIENS,RAIENSUB,RALAST,RALCKFLG,RAMEMARR,RANME,RANODE "RTN","RARTE6",248,0) K RAOUT,RAPIECE,RAPRC,RAPRTSET,RAPRVIEN,RAPREV,RAPRVST,RAROOT,RARPT "RTN","RARTE6",249,0) K RASSN,RAST,RASUB70,RASUBY0,RAX,RAXIT,X,XY,Y,Z "RTN","RARTE6",250,0) Q "RTN","RARTE6",251,0) DISPLAY ; Display exam specific info, edit/enter the report "RTN","RARTE6",252,0) ; adapted from routine RARTE "RTN","RARTE6",253,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RARTE6",254,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN) "RTN","RARTE6",255,0) S RA18EX=0 ;P18 for quit if uparrow inside PUTTCOM "RTN","RARTE6",256,0) I '($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))#2) D D Q1^RARTE5 QUIT "RTN","RARTE6",257,0) . I $$USESSAN^RAHLRU1() W !!?2,"Case #: ",RACNDSP," for ",RANME S RAXIT=1 "RTN","RARTE6",258,0) . I '$$USESSAN^RAHLRU1() W !!?2,"Case #: ",RACN," for ",RANME S RAXIT=1 "RTN","RARTE6",259,0) . W !?2,"Procedure: '",$E(RAPRC,1,45),"' has been deleted" "RTN","RARTE6",260,0) . W !?2,"by another user!",$C(7) "RTN","RARTE6",261,0) . Q "RTN","RARTE6",262,0) ; "RTN","RARTE6",263,0) S RAI="",$P(RAI,"-",80)="" W !,RAI "RTN","RARTE6",264,0) W !?1,"Name : ",$E(RANME,1,25),?40,"Pt ID : ",RASSN "RTN","RARTE6",265,0) I $$USESSAN^RAHLRU1() W !?1,"Case No. : ",RACNDSP,?40,"Exm. St : ",$E($P($G(^RA(72,+RAST,0)),"^"),1,22),!?1,"Procedure: ",$E(RAPRC,1,45) "RTN","RARTE6",266,0) I '$$USESSAN^RAHLRU1() W !?1,"Case No. : ",RACN,?18,"Exm. St: ",$E($P($G(^RA(72,+RAST,0)),"^"),1,12),?40,"Procedure : ",$E(RAPRC,1,25) "RTN","RARTE6",267,0) ;check for contrast media; display if CM data exists (patch 45) "RTN","RARTE6",268,0) S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI) "RTN","RARTE6",269,0) D:$L(RACMDATA) CMEDIA^RARTE(RACMDATA) "RTN","RARTE6",270,0) K RACMDATA "RTN","RARTE6",271,0) S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,RACN," Tech.Comment: ",15,70,-1,0) ;P18 "RTN","RARTE6",272,0) I RA18EX=-1 Q ;P18 "RTN","RARTE6",273,0) ; "RTN","RARTE6",274,0) K RAMEMARR D EN2^RAUTL20(.RAMEMARR) ;recalculate RAPRTSET "RTN","RARTE6",275,0) ; if printset, display cases and continue on to display Exam Date "RTN","RARTE6",276,0) I RAPRTSET D "RTN","RARTE6",277,0) . S RA1="" "RTN","RARTE6",278,0) . F S RA1=$O(RAMEMARR(RA1)) Q:RA1=""!(RA18EX=-1) I RA1'=RACNI D "RTN","RARTE6",279,0) .. I $$USESSAN^RAHLRU1() W !,?1,"Case No. : ",$P(RAMEMARR(RA1),U) "RTN","RARTE6",280,0) .. I '$$USESSAN^RAHLRU1() W !,?1,"Case No. : ",+RAMEMARR(RA1) "RTN","RARTE6",281,0) .. I $$USESSAN^RAHLRU1() W:$P(RAMEMARR(RA1),"^",4)]"" ?40,"Exm. St : ",$E($P($G(^RA(72,$P(RAMEMARR(RA1),"^",4),0)),"^"),1,22) W !?1,"Procedure: ",$E($P($G(^RAMIS(71,+$P(RAMEMARR(RA1),"^",2),0)),"^"),1,45) "RTN","RARTE6",282,0) .. I '$$USESSAN^RAHLRU1() W:$P(RAMEMARR(RA1),"^",4)]"" ?18,"Exm. St: ",$E($P($G(^RA(72,$P(RAMEMARR(RA1),"^",4),0)),"^"),1,12) W ?40,"Procedure : ",$E($P($G(^RAMIS(71,+$P(RAMEMARR(RA1),"^",2),0)),"^"),1,26) "RTN","RARTE6",283,0) .. ;check printset for contrast media; display if CM data exists "RTN","RARTE6",284,0) .. S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RA1) "RTN","RARTE6",285,0) .. D:$L(RACMDATA) CMEDIA^RARTE(RACMDATA) "RTN","RARTE6",286,0) .. K RACMDATA "RTN","RARTE6",287,0) .. I $P(RAMEMARR(RA1),"^")["-" S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,$P($P(RAMEMARR(RA1),"^"),"-",3)," Tech.Comment: ",15,70,-1,0) Q:RA18EX=-1 "RTN","RARTE6",288,0) .. I $P(RAMEMARR(RA1),"^")'["-" S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,+RAMEMARR(RA1)," Tech.Comment: ",15,70,-1,0) Q:RA18EX=-1 ;P18 "RTN","RARTE6",289,0) .. Q "RTN","RARTE6",290,0) . Q "RTN","RARTE6",291,0) ;continue display "RTN","RARTE6",292,0) I RA18EX=-1 Q ;P18 "RTN","RARTE6",293,0) S Y(0)=RASUBY0 "RTN","RARTE6",294,0) S RAIENS=RACNI_","_RADTI_","_RADFN_"," "RTN","RARTE6",295,0) D GETS^DIQ(70.03,RAIENS,"14;175*","E","RAOUT") "RTN","RARTE6",296,0) W !?1,"Exam Date: ",RADATE,?40,"Technologist: " "RTN","RARTE6",297,0) S RAIENSUB=$O(RAOUT(70.12,0)) "RTN","RARTE6",298,0) W:RAIENSUB]"" $E($G(RAOUT(70.12,RAIENSUB,.01,"E")),1,25) "RTN","RARTE6",299,0) ;p99 begins "RTN","RARTE6",300,0) W !?1,"Req Phys : ",$E($G(RAOUT(70.03,RAIENS,14,"E")),1,25) "RTN","RARTE6",301,0) I $$PTSEX^RAUTL8(RADFN)="F" D "RTN","RARTE6",302,0) .D GETS^DIQ(70.03,RAIENS,"32;80","I","RAOUT") "RTN","RARTE6",303,0) .N RA3 S RA3=$G(RAOUT(70.03,RAIENS,32,"I")) "RTN","RARTE6",304,0) .W:RA3'="" !?1,"Pregnancy Screen: ",$S(RA3="y":"Patient answered yes",RA3="n":"Patient answered no",RA3="u":"Patient is unable to answer or is unsure",1:"") "RTN","RARTE6",305,0) .W:(RA3'="n")&($G(RAOUT(70.03,RAIENS,80,"I"))'="") !?1,"Pregnancy Screen Comment: ",$G(RAOUT(70.03,RAIENS,80,"I")) "RTN","RARTE6",306,0) ;p99 ends "RTN","RARTE6",307,0) W !,RAI "RTN","RARTE6",308,0) Q "RTN","RARTE6",309,0) LOCK(X,Y) ; Lock the data global "RTN","RARTE6",310,0) ; uses var DILOCKTM, code taken from rtn RAUTL12 "RTN","RARTE6",311,0) ; 'X' is the global root "RTN","RARTE6",312,0) ; 'Y' is the record number "RTN","RARTE6",313,0) N RALCKFLG,XY "RTN","RARTE6",314,0) S RADUZ=+$G(DUZ),RALCKFLG=0,XY=X_Y "RTN","RARTE6",315,0) L +@(XY_")"):DILOCKTM "RTN","RARTE6",316,0) I '$T S RALCKFLG=1 D "RTN","RARTE6",317,0) . W !?5,"This record is being edited by another user." "RTN","RARTE6",318,0) . W !?5,"Try again later!",$C(7) "RTN","RARTE6",319,0) . Q "RTN","RARTE6",320,0) E D "RTN","RARTE6",321,0) . S ^TMP("RAD LOCKS",$J,RADUZ,X,Y)="" "RTN","RARTE6",322,0) . Q "RTN","RARTE6",323,0) Q RALCKFLG "RTN","RARTE6",324,0) INTRO ; "RTN","RARTE6",325,0) ;; +--------------------------------------------------------+ "RTN","RARTE6",326,0) ;; | | "RTN","RARTE6",327,0) ;; | This option is for restoring a deleted report. | "RTN","RARTE6",328,0) ;; | | "RTN","RARTE6",329,0) ;; +--------------------------------------------------------+ "RTN","RARTR3") 0^54^B28579692 "RTN","RARTR3",1,0) RARTR3 ;HIRMFO/SWM-Queue/print Radiology Reports (utility) ;8/31/99 13:57 "RTN","RARTR3",2,0) ;;5.0;Radiology/Nuclear Medicine;**8,10,19,27,35,45,75,47**;Mar 16, 1998;Build 21 "RTN","RARTR3",3,0) MEMS1 ;--- modifiers --- handle cases within print set "RTN","RARTR3",4,0) N RACNISAV,RAY3SAV,RAMEMARR,RACDIS,RALDIS "RTN","RARTR3",5,0) D EN2^RAUTL20(.RAMEMARR) Q:'$O(RAMEMARR(0)) "RTN","RARTR3",6,0) S RACNISAV=RACNI,RAY3SAV=RAY3,RACNI=0 "RTN","RARTR3",7,0) D CDIS^RAPROD S (RAREZON,RACNI)=0 "RTN","RARTR3",8,0) ;for printsets print the REASON FOR STUDY along with the lead procedure "RTN","RARTR3",9,0) ;(avoid duplicate printing of the same data) "RTN","RARTR3",10,0) F S RACNI=$O(RAMEMARR(RACNI)) Q:'RACNI D S:$G(RAXIT) RAOOUT=1 Q:$D(RAOOUT) "RTN","RARTR3",11,0) . S RAY3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) "RTN","RARTR3",12,0) . ;Check if cancelled & not part of printset "RTN","RARTR3",13,0) . I $P(^RA(72,+$P(RAY3,"^",3),0),"^",3)=0,($P(RAY3,"^",17)="") Q "RTN","RARTR3",14,0) . D MODS^RAUTL2 "RTN","RARTR3",15,0) . ; If printing page at a time we need to check the length - RA*5*8 "RTN","RARTR3",16,0) . I '$D(RAUTOE),$Y>(IOSL-6),IOST["C-" S RAP="" D WAIT^RART1 I X="^"!(X="P")!(X="T") S RAOOUT=1 Q "RTN","RARTR3",17,0) . D OUT1 Q:$G(RAXIT) S RAREZON=1 "RTN","RARTR3",18,0) . D:+$P(RAY3,"^",28) RDIO^RARTUTL(+$P(RAY3,"^",28)) Q:$D(RAOOUT) "RTN","RARTR3",19,0) . D:+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) PHARM^RARTUTL(RACNI_","_RADTI_","_RADFN_",") "RTN","RARTR3",20,0) . Q "RTN","RARTR3",21,0) S RACNI=RACNISAV,RAY3=RAY3SAV K RAREZON "RTN","RARTR3",22,0) Q "RTN","RARTR3",23,0) OUT1 ; "RTN","RARTR3",24,0) ; $O(RAMEMARR(0)) may be defined, if previously called MEMS1^RARTR3 "RTN","RARTR3",25,0) ; RALDIS flags long display wanted, comes from certain output options "RTN","RARTR3",26,0) ; RACDIS(n) exists if case n is to be displayed "RTN","RARTR3",27,0) ; RACDIS(n) not set for dupl proc+pmod+cptmod so don't display "RTN","RARTR3",28,0) I $O(RAMEMARR(0)),'$G(RALDIS),'$D(RACDIS(RACNI)) Q "RTN","RARTR3",29,0) S RASTUDY=$P($G(^RAO(75.1,+$P(RAY3,U,11),.1)),U) ;Convey 'Reason for Study' P75 "RTN","RARTR3",30,0) I $D(RAUTOE) G MAIL1 "RTN","RARTR3",31,0) W !,$$XAM() "RTN","RARTR3",32,0) ;check for contrast media; display if CM data exists (patch 45) "RTN","RARTR3",33,0) S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI) "RTN","RARTR3",34,0) I $L(RACMDATA) D "RTN","RARTR3",35,0) .W !?5,"Contrast Media :" "RTN","RARTR3",36,0) .F RAIZ=1:1 Q:$P(RACMDATA,", ",RAIZ)="" D "RTN","RARTR3",37,0) ..W ?22,$P(RACMDATA,", ",RAIZ) "RTN","RARTR3",38,0) ..W:$P(RACMDATA,", ",RAIZ+1)'="" ! "RTN","RARTR3",39,0) ..I $Y>(IOSL-5) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF W ! "RTN","RARTR3",40,0) ..Q "RTN","RARTR3",41,0) .K RAIZ "RTN","RARTR3",42,0) .QUIT "RTN","RARTR3",43,0) K RACMDATA Q:$G(RAXIT) "RTN","RARTR3",44,0) W:Y'="None" !?RATAB,"Proc Modifiers : ",Y "RTN","RARTR3",45,0) N I,J "RTN","RARTR3",46,0) W:Y(1)'="None" !?RATAB,"CPT Modifiers : " "RTN","RARTR3",47,0) I Y(1)'="None" F I=1:1 Q:$P(Y(2),", ",I)']"" S J=$P(Y(2),", ",I),J=$$BASICMOD^RACPTMSC(J,DT) W ?22,$P(J,"^",2)," ",$P(J,"^",3) W:$P(Y(2),", ",I+1)]"" ! I $Y>(IOSL-5) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF W ! "RTN","RARTR3",48,0) I $L(RASTUDY),$G(RAREZON,0)=0 W ! D DIWP^RAUTL5(RATAB,68,"Reason for Study: "_RASTUDY) ;P75 "RTN","RARTR3",49,0) K RASTUDY "RTN","RARTR3",50,0) Q "RTN","RARTR3",51,0) ; "RTN","RARTR3",52,0) MAIL1 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="" "RTN","RARTR3",53,0) S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$$XAM() "RTN","RARTR3",54,0) ;check for contrast media; display if CM data exists (patch 45) "RTN","RARTR3",55,0) S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI) "RTN","RARTR3",56,0) I $L(RACMDATA) D "RTN","RARTR3",57,0) .S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Contrast Media : "_$P(RACMDATA,", ") "RTN","RARTR3",58,0) .F RAIZ=2:1 Q:$P(RACMDATA,", ",RAIZ)="" S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$P(RACMDATA,", ",RAIZ) "RTN","RARTR3",59,0) .K RAIZ "RTN","RARTR3",60,0) .Q "RTN","RARTR3",61,0) K RACMDATA "RTN","RARTR3",62,0) S:Y'="None" ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Proc Modifiers : "_Y "RTN","RARTR3",63,0) I Y(1)'="None" D "RTN","RARTR3",64,0) .S J=$P(Y(2),", ",1),J=$$BASICMOD^RACPTMSC(J,DT) S:+J<0 $P(J,"^",2,3)="None^" "RTN","RARTR3",65,0) .S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" CPT Modifiers : "_$S(J]"":$P(J,"^",2)_" "_$P(J,"^",3),1:"") "RTN","RARTR3",66,0) .F I=2:1 Q:$P(Y(2),", ",I)']"" S J=$P(Y(2),", ",I),J=$$BASICMOD^RACPTMSC(J,DT) S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$P(J,"^",2)_" "_$P(J,"^",3) "RTN","RARTR3",67,0) .Q "RTN","RARTR3",68,0) I $L(RASTUDY),$G(RAREZON,0)=0 D S RAREZON=1 "RTN","RARTR3",69,0) .N RAY S RASTUDY="Reason for Study: "_RASTUDY "RTN","RARTR3",70,0) .I $L(RASTUDY)'>68 S $P(RAY," ",6)="",^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAY_RASTUDY Q "RTN","RARTR3",71,0) .I $L(RASTUDY)>68 D "RTN","RARTR3",72,0) ..K ^UTILITY($J,"W") N %,DIW,DIWF,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,RAI,RAX,X,X1,Z "RTN","RARTR3",73,0) ..S DIWF="",DIWL=1,DIWR=65,X=RASTUDY D ^DIWP "RTN","RARTR3",74,0) ..S RAI=0 F S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI D "RTN","RARTR3",75,0) ...S RAX=$G(^UTILITY($J,"W",DIWL,RAI,0)) "RTN","RARTR3",76,0) ...I RAI=1 S $P(RAY," ",6)="",^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAY_RAX "RTN","RARTR3",77,0) ...I RAI'=1 S $P(RAY," ",24)="",^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAY_RAX "RTN","RARTR3",78,0) ...Q "RTN","RARTR3",79,0) ..Q "RTN","RARTR3",80,0) .K ^UTILITY($J,"W") "RTN","RARTR3",81,0) .Q "RTN","RARTR3",82,0) K RASTUDY "RTN","RARTR3",83,0) Q "RTN","RARTR3",84,0) ; "RTN","RARTR3",85,0) XAM() ; Return exam data information. Case number, exam status & procedure "RTN","RARTR3",86,0) ; name build into one string. Assumes RAY3 is the 0 node for exam data "RTN","RARTR3",87,0) Q:$G(RAY3)="" "" ; no exam information present. "RTN","RARTR3",88,0) N RAPROC,RAXAMSTR S RAXAMSTR="" "RTN","RARTR3",89,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RARTR3",90,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:+RAY3) "RTN","RARTR3",91,0) I $G(RAMDIV)="" S RAMDIV=$P($G(^RADPT(RADFN,"DT",RADTI,0)),"^",3) "RTN","RARTR3",92,0) I $G(RALDIS)!('$O(RAMEMARR(0)))!($O(RAMEMARR(0))&($G(RACDIS(RACNI))=1)) D "RTN","RARTR3",93,0) . I $$USESSAN^RAHLRU1() S $E(RAXAMSTR,1,5)="(Case" S $E(RAXAMSTR,7,(7+$L(RACNDSP)))=RACNDSP "RTN","RARTR3",94,0) . I '$$USESSAN^RAHLRU1() S $E(RAXAMSTR,1,5)="(Case" S $E(RAXAMSTR,7,(7+$L(+RAY3)))=+RAY3 "RTN","RARTR3",95,0) . S $E(RAXAMSTR,$L(RAXAMSTR)+2,79)=$S($D(^RA(72,+$P(RAY3,"^",3),0)):$E($P(^(0),"^"),1,8)_")",1:"Unknown)") "RTN","RARTR3",96,0) . Q "RTN","RARTR3",97,0) E S:$G(RACDIS(RACNI)) $E(RAXAMSTR,1)="(",$E(RAXAMSTR,9,14)=RACDIS(RACNI)_"x",$E(RAXAMSTR,20)=")" "RTN","RARTR3",98,0) S RAPROC=$G(^RAMIS(71,+$P(RAY3,"^",2),0)) "RTN","RARTR3",99,0) I $$USESSAN^RAHLRU1() S $E(RAXAMSTR,32,65)=$S($P(RAPROC,"^")]"":$E($P(RAPROC,"^"),1,33),1:"Unknown") "RTN","RARTR3",100,0) I '$$USESSAN^RAHLRU1() S $E(RAXAMSTR,22,54)=$S($P(RAPROC,"^")]"":$E($P(RAPROC,"^"),1,33),1:"Unknown") "RTN","RARTR3",101,0) N RADISPLY "RTN","RARTR3",102,0) S RADISPLY=$G(^RAMIS(71,+$P($G(^RADPT(+RADFN,"DT",+RADTI,"P",+RACNI,0)),U,2),0)) ; set $ZR to 71 for prccpt^radd1, not call raprod since store result "RTN","RARTR3",103,0) S RADISPLY=$$PRCCPT^RADD1() "RTN","RARTR3",104,0) I $$USESSAN^RAHLRU1() S $E(RAXAMSTR,65,79)=RADISPLY "RTN","RARTR3",105,0) I '$$USESSAN^RAHLRU1() S $E(RAXAMSTR,55,79)=RADISPLY "RTN","RARTR3",106,0) Q RAXAMSTR "RTN","RARTST2A") 0^55^B25475148 "RTN","RARTST2A",1,0) RARTST2A ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Reports Distribution ;11/24/97 12:12 "RTN","RARTST2A",2,0) ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21 "RTN","RARTST2A",3,0) ; "RTN","RARTST2A",4,0) DIV ; Division selection "RTN","RARTST2A",5,0) ; save all Med Center Divisions (40.8) by pntr to file 4 "RTN","RARTST2A",6,0) D LIST^DIC(40.8,"",.07,"I","*","","","","","","RA408") "RTN","RARTST2A",7,0) Q:'$D(RA408("DILIST","ID")) ; quit if no data "RTN","RARTST2A",8,0) S RAI=0 F S RAI=$O(RA408("DILIST","ID",RAI)) Q:RAI'>0 D "RTN","RARTST2A",9,0) . ; for all entries in 40.8, save off the Institution File Pointer data "RTN","RARTST2A",10,0) . ; (Inst. File Pntr data is subscript) set the local array equal to the "RTN","RARTST2A",11,0) . ; appropriate ien in 40.8 - Example: RA4('ien file 4')='ien file 40.8' "RTN","RARTST2A",12,0) . S:$G(RA408("DILIST","ID",RAI,.07))]"" RA4($G(RA408("DILIST","ID",RAI,.07)))=$G(RA408("DILIST",2,RAI)) "RTN","RARTST2A",13,0) . S:$G(RA408("DILIST",2,RAI))]"" RAF408(RA408("DILIST",2,RAI))="" "RTN","RARTST2A",14,0) . Q "RTN","RARTST2A",15,0) K RAPRMPT S I1=$P($G(^RABTCH(74.3,RAB,0)),"^") "RTN","RARTST2A",16,0) I I1="CLINIC REPORTS"!(I1="WARD REPORTS")!(I1="REQUESTING PHYSICIAN") S RAPRMPT=" Requesting Division: " "RTN","RARTST2A",17,0) E S RAPRMPT=" Exam Division: " "RTN","RARTST2A",18,0) K RADIV S (C,I1)=0 F I=0:0 S I=$O(^RA(79,I)) Q:'I S C=C+1,I1=I Q:C>1 "RTN","RARTST2A",19,0) I C=1,$D(RA4(I1)) S RADIV=I1 K C,I,I1 G IMAG "RTN","RARTST2A",20,0) I $D(RAMDIV),$D(RA4(+RAMDIV)) S DIC("B")=+RAMDIV "RTN","RARTST2A",21,0) W !!,"Division Selection:",!,"-------------------" "RTN","RARTST2A",22,0) S DIC(0)="AEMQZ",DIC="^DIC(4,",DIC("A")=RAPRMPT "RTN","RARTST2A",23,0) S DIC("S")="I $D(RA4(+Y))" ; only institutions linked to Med Center Divs "RTN","RARTST2A",24,0) D ^DIC K DIC("A"),DIC("B"),DIC("S"),RAPRMPT S RADIV=+Y "RTN","RARTST2A",25,0) K C,I,I1,RA408,RAI Q:RADIV'>0 "RTN","RARTST2A",26,0) S I=0 F S I=$O(RA4(I)) Q:I'>0 D "RTN","RARTST2A",27,0) . S I(0)=$G(RA4(I)) "RTN","RARTST2A",28,0) . I I'=RADIV K RA4(I),RAF408(I(0)) "RTN","RARTST2A",29,0) . Q "RTN","RARTST2A",30,0) K I "RTN","RARTST2A",31,0) ; "RTN","RARTST2A",32,0) IMAG ;imaging type selection "RTN","RARTST2A",33,0) K RAIMAG I $D(RAOMA) D Q:'$D(RAIMAG) "RTN","RARTST2A",34,0) . S RAIMAG=$$IMG^RARTST3() "RTN","RARTST2A",35,0) . ; allow the users to select all i-types regardless of division "RTN","RARTST2A",36,0) . ; if i-types have been selected, RAIMAG is set to one, else 0 "RTN","RARTST2A",37,0) . K:'RAIMAG RAIMAG "RTN","RARTST2A",38,0) . Q "RTN","RARTST2A",39,0) E D Q:'$D(RAIMAG) "RTN","RARTST2A",40,0) . W !!,"Imaging Type Selection:",!,"-----------------------" "RTN","RARTST2A",41,0) . S DIR(0)="PA^79.2:AEMQ",DIR("A")="Select Imaging Type: " "RTN","RARTST2A",42,0) . S:$D(RAMLC) DIR("B")=$P($$IMAG^RASITE(+$P(RAMLC,U,6)),U,2) "RTN","RARTST2A",43,0) . D ^DIR K DIR Q:Y'>0!$D(DIRUT) S RAIMAG(+Y)="" "RTN","RARTST2A",44,0) . Q "RTN","RARTST2A",45,0) I $D(^RABTCH(74.3,"B","REQUESTING PHYSICIAN",RAB))#2 D G LOC "RTN","RARTST2A",46,0) . S RASRT(0)="Patient",RASRT="P" "RTN","RARTST2A",47,0) . Q "RTN","RARTST2A",48,0) ; "RTN","RARTST2A",49,0) SORT W !!,"Sort Sequence Selection:",!,"------------------------" "RTN","RARTST2A",50,0) K RASRT S RARD(1)="Terminal Digits^sort reports by terminal digit of SSN",RARD(2)="SSN^sort reports by SSN",RARD(3)="Patient^sort reports by patient's name",RARD("A")="Select Sequence: ",RARD("B")=3 "RTN","RARTST2A",51,0) D SET^RARD K RARD Q:"^"[X S RASRT=$E(X),RASRT(0)=X "RTN","RARTST2A",52,0) ; "RTN","RARTST2A",53,0) LOC I $G(RARTST1)=1 D Q:"^"[RALOCSRT ; *** [RA RPTDISTQUE] option only *** "RTN","RARTST2A",54,0) . W !!,"First Sort Selection:",!,"---------------------" "RTN","RARTST2A",55,0) . K DIR S DIR(0)="YO",DIR("B")="Yes" "RTN","RARTST2A",56,0) . S DIR("A")=" Sort by patient location before "_RASRT(0) "RTN","RARTST2A",57,0) . S DIR("?",1)="Enter YES to sort the report by patient location, then by "_RASRT(0)_"." "RTN","RARTST2A",58,0) . S DIR("?",2)="Enter NO to sort the report by "_RASRT(0)_", with no sort by location." "RTN","RARTST2A",59,0) . S DIR("?")="Choose either YES or NO." "RTN","RARTST2A",60,0) . D ^DIR K DIR S RALOCSRT=$S($D(DIRUT):U,1:Y) "RTN","RARTST2A",61,0) . Q "RTN","RARTST2A",62,0) E S RALOCSRT=1 "RTN","RARTST2A",63,0) ; "RTN","RARTST2A",64,0) PRINT K RAPRT W !!,"Print/Reprint Reports Selection:",!,"--------------------------------" "RTN","RARTST2A",65,0) S RARD(1)="UNPRINTED^print verified reports that have not been printed",RARD(2)="REPRINT^reprint previously printed reports",RARD("B")=1 D SET^RARD K RARD Q:"^"[X "RTN","RARTST2A",66,0) S RAPRT=X Q:$E(RAPRT)="U" "RTN","RARTST2A",67,0) ; "RTN","RARTST2A",68,0) DATE K RABEG,RAEND W !!,"Date Range Selection:",!,"---------------------" "RTN","RARTST2A",69,0) S %DT("B")="T@1201AM",%DT="APRETX",%DT("A")=" Beginning DATE/TIME of Initial Print : " D ^%DT I Y<0 K RAPRT Q "RTN","RARTST2A",70,0) S (%DT(0),RABEG)=Y "RTN","RARTST2A",71,0) W ! S %DT("B")="NOW",%DT="APRETX",%DT("A")=" Ending DATE/TIME of Initial Print : " D ^%DT K %DT I Y<0 K RAPRT Q "RTN","RARTST2A",72,0) W ! S RAEND=Y Q "RTN","RARTST2A",73,0) RPTST(RARPT) ; Report's Print Status, called from 8^RARTST1. "RTN","RARTST2A",74,0) ; This code replaces the call to the compiled template routine. "RTN","RARTST2A",75,0) ; Input: RARPT -> ien of the Report in file 74 "RTN","RARTST2A",76,0) N I,RA74,RAEXFLD,RAY3,X,Y W !,$$REPEAT^XLFSTR("-",IOM),!! "RTN","RARTST2A",77,0) S RA74(0)=$G(^RARPT(RARPT,0)) W "Report : ",$P(RA74(0),"^") "RTN","RARTST2A",78,0) S (X,Y)=+$P(RA74(0),"^",2),Y=$S($D(^DPT(Y,0))#2:$P(^(0),"^"),1:"") "RTN","RARTST2A",79,0) W ?30,"Patient: ",$E(Y,1,25) W:X ?65,$$SSN^RAUTL(X) "RTN","RARTST2A",80,0) S Y=+$O(^RADPT(X,"DT",(9999999.9999-$P(RA74(0),"^",3)),"P","B",$P(RA74(0),"^",4),0)) "RTN","RARTST2A",81,0) S RAY3=$G(^RADPT(X,"DT",(9999999.9999-$P(RA74(0),"^",3)),"P",Y,0)) "RTN","RARTST2A",82,0) S RAEXFLD="PROC" D ^RARTFLDS W !,"Procedure: ",$E(X,1,30) "RTN","RARTST2A",83,0) W ?45,"Verified: ",$$FMTE^XLFDT($P(RA74(0),"^",7),"1P") "RTN","RARTST2A",84,0) W !!?4,"Routing Queue",?24,"Date Printed",?44,"Printed By",?62,"Ward/Clinic" "RTN","RARTST2A",85,0) W !?4,"-------------",?24,"------------",?44,"----------",?62,"-----------" "RTN","RARTST2A",86,0) S I=0 F S I=$O(^RABTCH(74.4,"B",RARPT,I)) Q:I'>0 D "RTN","RARTST2A",87,0) . S X=$G(^RABTCH(74.4,I,0)),Y=+$P(X,"^",11) "RTN","RARTST2A",88,0) . S Y=$S($D(^RABTCH(74.3,Y,0))#2:$P(^(0),"^"),1:"") "RTN","RARTST2A",89,0) . W !,$E(Y,1,20),?24,$E($$FMTE^XLFDT($P(X,"^",4),1),1,18) "RTN","RARTST2A",90,0) . S Y=+$P(X,"^",3),Y=$S($D(^VA(200,Y,0))#2:$P(^(0),"^"),1:"") "RTN","RARTST2A",91,0) . W ?44,$E(Y,1,17),?62 "RTN","RARTST2A",92,0) . W:+$P(X,"^",6) $E($$GET1^DIQ(42,+$P(X,"^",6),.01),1,18) "RTN","RARTST2A",93,0) . W:+$P(X,"^",8) $E($$GET1^DIQ(44,+$P(X,"^",6),.01),1,18) "RTN","RARTST2A",94,0) . Q "RTN","RARTST2A",95,0) W !!,$$REPEAT^XLFSTR("=",IOM),! "RTN","RARTST2A",96,0) Q "RTN","RARTUVR3") 0^56^B35802159 "RTN","RARTUVR3",1,0) RARTUVR3 ;HISC/GJC-Unverified Reports ;8/19/97 11:28 "RTN","RARTUVR3",2,0) ;;5.0;Radiology/Nuclear Medicine;**56,47**;Mar 16, 1998;Build 21 "RTN","RARTUVR3",3,0) ;Supported IA #2056 GET1^DIQ "RTN","RARTUVR3",4,0) EN1 ; Entry point for unverified reports option when sort is on "RTN","RARTUVR3",5,0) ; Exam Date or Pri. Inter. Staff "RTN","RARTUVR3",6,0) ; Data Storage: "RTN","RARTUVR3",7,0) ; RABD="E": "RTN","RARTUVR3",8,0) ; ^TMP($J,"RAUVR",Division,Xam Date/Time,Patient,Case #)=print set? (1:yes, 0:no)_^_Pat ID_^_0 node of exam "RTN","RARTUVR3",9,0) ; RABD="S": "RTN","RARTUVR3",10,0) ; ^TMP($J,"RAUVR",Pri. Staff,Xam Date/Time,Patient,Case #)=print set? (1:yes, 0:no)_^_Pat ID_^_0 node of exam "RTN","RARTUVR3",11,0) K ^TMP($J,"RAUVR") S (RAOUT,RAPAGE)=0,RASTATUS="" "RTN","RARTUVR3",12,0) D:RABD="E" ZERO ; zero out totals for division data "RTN","RARTUVR3",13,0) S RADTE=BEGDATE-.0001 "RTN","RARTUVR3",14,0) F S RADTE=$O(^RADPT("AR",RADTE)) Q:RADTE'>0!(RADTE>ENDDATE)!(RAOUT) D "RTN","RARTUVR3",15,0) . S RADFN=0 "RTN","RARTUVR3",16,0) . F S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:RADFN'>0!(RAOUT) D "RTN","RARTUVR3",17,0) .. S RADTI=0 "RTN","RARTUVR3",18,0) .. F S RADTI=$O(^RADPT("AR",RADTE,RADFN,RADTI)) Q:RADTI'>0!(RAOUT) D "RTN","RARTUVR3",19,0) ... S RACN=0 "RTN","RARTUVR3",20,0) ... F S RACN=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN)) Q:RACN'>0!(RAOUT) D "RTN","RARTUVR3",21,0) .... S RACNI=+$O(^RADPT(RADFN,"DT",RADTI,"P","B",RACN,0)) Q:'RACNI "RTN","RARTUVR3",22,0) .... S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) "RTN","RARTUVR3",23,0) .... Q:'+$P(RA7003,"^",17) ; no report "RTN","RARTUVR3",24,0) .... S RA74=$G(^RARPT(+$P(RA7003,"^",17),0)) "RTN","RARTUVR3",25,0) .... Q:$P(RA74,"^",5)="" ; no status, skeletal rpt created by imaging "RTN","RARTUVR3",26,0) .... Q:"^V^X^EF^"[("^"_$P(RA74,"^",5)_"^") ;Skip Verified, Deleted, E-filed rpts "RTN","RARTUVR3",27,0) .... I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1 Q:RAOUT "RTN","RARTUVR3",28,0) .... ; ***** check if user selected this division & imaging type **** "RTN","RARTUVR3",29,0) .... S RA7002=$G(^RADPT(RADFN,"DT",RADTI,0)) ; 0 node Reg. Exams sub-file "RTN","RARTUVR3",30,0) .... S RADIVNME=$P($G(^DIC(4,+$P(RA7002,"^",3),0)),"^") ; dinum to file 4! "RTN","RARTUVR3",31,0) .... S:RADIVNME="" RADIVNME="Unknown" "RTN","RARTUVR3",32,0) .... Q:'$D(^TMP($J,"RA D-TYPE",RADIVNME)) "RTN","RARTUVR3",33,0) .... Q:'$D(^TMP($J,"RA I-TYPE",$P($G(^RA(79.2,+$P(RA7002,"^",2),0)),"^"))) "RTN","RARTUVR3",34,0) .... ;***************************************************************** "RTN","RARTUVR3",35,0) .... S (RAMEMLOW,RAPRTSET,RAPSET)=0 D EN1^RAUTL20 ; mem of a printset? "RTN","RARTUVR3",36,0) .... S:RAPRTSET RAPSET="1." S:RAMEMLOW RAPSET="1+" "RTN","RARTUVR3",37,0) .... S RAPIS=$$GET1^DIQ(200,+$P(RA7003,"^",15)_",",.01) "RTN","RARTUVR3",38,0) .... S:RAPIS="" RAPIS="Unknown" "RTN","RARTUVR3",39,0) .... S RAPAT=$G(^DPT(RADFN,0)) "RTN","RARTUVR3",40,0) .... S RASSN=$$SSN^RAUTL() S:RASSN="" RASSN="Unknown" "RTN","RARTUVR3",41,0) .... S RAPAT=$P(RAPAT,"^") S:RAPAT="" RAPAT="Unknown" "RTN","RARTUVR3",42,0) .... ;***************************************************************** "RTN","RARTUVR3",43,0) .... ; Store off the data into our TMP global. First subscript is $J. "RTN","RARTUVR3",44,0) .... ; Second subscript is: RABD="E", exam date. I RABD="S", second "RTN","RARTUVR3",45,0) .... ; subscript is Pri. Int'g Staff. Other Subscripts: sub3-exam date, "RTN","RARTUVR3",46,0) .... ; sub4-patient name, sub5-case number "RTN","RARTUVR3",47,0) .... S:RABD="E" ^TMP($J,"RAUVR",RADIVNME,($P(RA7002,"^")\1),RAPAT,+$P(RA7003,"^"))=RAPSET_"^"_RASSN_"^"_RA7003 "RTN","RARTUVR3",48,0) .... S:RABD="S" ^TMP($J,"RAUVR",RAPIS,($P(RA7002,"^")\1),RAPAT,+$P(RA7003,"^"))=RAPSET_"^"_RASSN_"^"_RA7003 "RTN","RARTUVR3",49,0) .... S:RABD="E" ^TMP($J,"RAUVR",RADIVNME)=+$G(^TMP($J,"RAUVR",RADIVNME))+1 "RTN","RARTUVR3",50,0) .... ;***************************************************************** "RTN","RARTUVR3",51,0) .... Q "RTN","RARTUVR3",52,0) ... Q "RTN","RARTUVR3",53,0) .. Q "RTN","RARTUVR3",54,0) . Q "RTN","RARTUVR3",55,0) S:RABD="S" RAHD="UNVERIFIED IMAGING REPORTS BY PRIMARY INTERPRETING STAFF" "RTN","RARTUVR3",56,0) S:RABD="E" RAHD="UNVERIFIED IMAGING REPORTS BY DIVISION" "RTN","RARTUVR3",57,0) S $P(RADASH,"-",(IOM+1))="" "RTN","RARTUVR3",58,0) I '$D(^TMP($J,"RAUVR")) D Q "RTN","RARTUVR3",59,0) . N RA1,RANODATA S RANODATA="*** No Unverified Reports ***",RA1="" "RTN","RARTUVR3",60,0) . I RABD="S" D HDR W !!?(IOM-$L(RANODATA)\2),RANODATA "RTN","RARTUVR3",61,0) . I RABD="E" D "RTN","RARTUVR3",62,0) .. N RA1 "RTN","RARTUVR3",63,0) .. S RA1="" F S RA=$O(^TMP($J,"RA D-TYPE",RA1)) Q:RA1="" D Q:RAOUT "RTN","RARTUVR3",64,0) ... D HDR "RTN","RARTUVR3",65,0) ... S RANODATA="*** No Unverified Reports for division: "_RA1_" ***" "RTN","RARTUVR3",66,0) ... W !!?(IOM-$L(RANODATA)\2),RANODATA "RTN","RARTUVR3",67,0) ... S:$O(^TMP($J,"RA D-TYPE",RA1))]"" RAOUT=$$EOS^RAUTL5() "RTN","RARTUVR3",68,0) ... Q "RTN","RARTUVR3",69,0) .. Q "RTN","RARTUVR3",70,0) . Q "RTN","RARTUVR3",71,0) D GETDATA "RTN","RARTUVR3",72,0) KILL ; cleanup symbol table "RTN","RARTUVR3",73,0) K RA7002,RA7003,RA74,RACSE,RAEXDT,RAHD,RAMEMLOW,RANODE,RAPAT,RAPIS "RTN","RARTUVR3",74,0) K RAPRC,RAPRTSET,RAPSET,RAXSTAT "RTN","RARTUVR3",75,0) Q "RTN","RARTUVR3",76,0) HDR ; header code "RTN","RARTUVR3",77,0) W:$Y @IOF ; clear screen if not at top-of-page "RTN","RARTUVR3",78,0) S RAPAGE=RAPAGE+1 W !?(IOM-$L(RAHD)\2),RAHD "RTN","RARTUVR3",79,0) W !,$S(RABD="S":"Primary Interpreting Staff: ",1:"Division: "),RA1 "RTN","RARTUVR3",80,0) W ?94,$$FMTE^XLFDT(DT,"1P")_" Page: "_RAPAGE "RTN","RARTUVR3",81,0) I $$USESSAN^RAHLRU1() W !,?93,"Exam",?102,"Report",!,"Patient",?21,"Patient ID",?34,"Exam Date",?44,"Case",?61,"Procedure",?93,"Status",?102,"Entered",?112,"Pri. Int'g Staff" "RTN","RARTUVR3",82,0) I '$$USESSAN^RAHLRU1() W !,?87,"Exam",?96,"Report",!,"Patient",?21,"Patient ID",?38,"Exam Date",?48,"Case",?55,"Procedure",?87,"Status",?96,"Entered",?106,"Pri. Int'g Staff" "RTN","RARTUVR3",83,0) W !,RADASH "RTN","RARTUVR3",84,0) Q "RTN","RARTUVR3",85,0) GETDATA ; get to the data "RTN","RARTUVR3",86,0) S RA1="",(RAPAGE,RAOUT)=0 "RTN","RARTUVR3",87,0) F S RA1=$O(^TMP($J,"RAUVR",RA1)) Q:RA1="" D Q:RAOUT "RTN","RARTUVR3",88,0) . D HDR S RAEXDT=0 "RTN","RARTUVR3",89,0) . I RABD="E",$G(^TMP($J,"RAUVR",RA1))=0 D Q "RTN","RARTUVR3",90,0) .. S X="*** No Unverified Reports for division ***" "RTN","RARTUVR3",91,0) .. W !!?(IOM-$L(X)\2),X "RTN","RARTUVR3",92,0) .. S:$O(^TMP($J,"RAUVR",RA1))]"" RAOUT=$$EOS^RAUTL5() "RTN","RARTUVR3",93,0) .. Q "RTN","RARTUVR3",94,0) . F S RAEXDT=$O(^TMP($J,"RAUVR",RA1,RAEXDT)) Q:RAEXDT'>0 D Q:RAOUT "RTN","RARTUVR3",95,0) .. S RAPAT="" "RTN","RARTUVR3",96,0) .. F S RAPAT=$O(^TMP($J,"RAUVR",RA1,RAEXDT,RAPAT)) Q:RAPAT="" D Q:RAOUT "RTN","RARTUVR3",97,0) ... S RACSE=0 "RTN","RARTUVR3",98,0) ... F S RACSE=$O(^TMP($J,"RAUVR",RA1,RAEXDT,RAPAT,RACSE)) Q:RACSE'>0 D Q:RAOUT "RTN","RARTUVR3",99,0) .... I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAOUT=1 Q:RAOUT "RTN","RARTUVR3",100,0) .... S RANODE=$G(^TMP($J,"RAUVR",RA1,RAEXDT,RAPAT,RACSE)) "RTN","RARTUVR3",101,0) .... D PRTDATA "RTN","RARTUVR3",102,0) .... Q "RTN","RARTUVR3",103,0) ... Q "RTN","RARTUVR3",104,0) .. Q "RTN","RARTUVR3",105,0) . S:$O(^TMP($J,"RAUVR",RA1))]"" RAOUT=$$EOS^RAUTL5() "RTN","RARTUVR3",106,0) . Q "RTN","RARTUVR3",107,0) Q "RTN","RARTUVR3",108,0) PRTDATA ; print the data "RTN","RARTUVR3",109,0) S RAPRC=$E($S($P(^RAMIS(71,+$P(RANODE,"^",4),0),"^")]"":$P(^(0),"^"),1:"Unknown"),1,30) "RTN","RARTUVR3",110,0) S:+$P(RANODE,"^") RAPRC=$TR($P(RANODE,"^"),"1","")_RAPRC "RTN","RARTUVR3",111,0) S RAXSTAT=$E($S($P(^RA(72,+$P(RANODE,"^",5),0),"^")]"":$P(^(0),"^"),1:"Unknown"),1,7) "RTN","RARTUVR3",112,0) S RARPTENT=$$FMTE^XLFDT(($P($G(^RARPT(+$P(RANODE,"^",19),0)),"^",6)\1),"2P") "RTN","RARTUVR3",113,0) S:RABD="S" RAPIS=RA1 "RTN","RARTUVR3",114,0) S:RABD="E" RAPIS=$$GET1^DIQ(200,+$P(RANODE,"^",17)_",",.01) "RTN","RARTUVR3",115,0) S:RAPIS="" RAPIS="Unknown" "RTN","RARTUVR3",116,0) N RASSAN,RACNDSP S RASSAN=$P(RANODE,"^",33) "RTN","RARTUVR3",117,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACSE) "RTN","RARTUVR3",118,0) I $$USESSAN^RAHLRU1() W !,$E(RAPAT,1,20),?21,$P(RANODE,"^",2),?34,$$FMTE^XLFDT(RAEXDT,"2P"),?44,RACNDSP,?61,RAPRC,?93,RAXSTAT,?102,RARPTENT,?112,$E(RAPIS,1,19) "RTN","RARTUVR3",119,0) I '$$USESSAN^RAHLRU1() W !,$E(RAPAT,1,20),?21,$P(RANODE,"^",2),?38,$$FMTE^XLFDT(RAEXDT,"2P"),?48,RACSE,?55,RAPRC,?87,RAXSTAT,?96,RARPTENT,?106,$E(RAPIS,1,25) "RTN","RARTUVR3",120,0) I $Y>(IOSL-4) S RAOUT=$$EOS^RAUTL5() D:'RAOUT HDR "RTN","RARTUVR3",121,0) Q "RTN","RARTUVR3",122,0) ZERO ; set division totals to zero "RTN","RARTUVR3",123,0) S X="" F S X=$O(^TMP($J,"RA D-TYPE",X)) Q:X="" S ^TMP($J,"RAUVR",X)=0 "RTN","RARTUVR3",124,0) Q "RTN","RASTEXT") 0^57^B34738271 "RTN","RASTEXT",1,0) RASTEXT ;HISC/CAH,FPT,GJC AISC/TMP,TAC,RMO-Called by Status Tracking display,edit. Allow selection/edit of case if called from edit option ;7/16/04 07:50 "RTN","RASTEXT",2,0) ;;5.0;Radiology/Nuclear Medicine;**48,47**;Mar 16, 1998;Build 21 "RTN","RASTEXT",3,0) S RAED=1 ;If called from beginning of routine, allow case edit "RTN","RASTEXT",4,0) ;If called at EN1, display exams by status but don't allow editing "RTN","RASTEXT",5,0) EN1 D SET^RAPSET1 I $D(XQUIT) K RAED,XQUIT Q "RTN","RASTEXT",6,0) D HOME^%ZIS S:'$D(RAED) RAED=0 S (RACTR,RAORD,RAXIT)=0 K RASTAT,RADTI "RTN","RASTEXT",7,0) N RADLOCS,RAQUIT,RATEMP,RATOTAL S (RATOTAL,X)=0 "RTN","RASTEXT",8,0) F S X=$O(^RA(79.1,X)) Q:X'>0 D "RTN","RASTEXT",9,0) . S Y=$G(^RA(79.1,X,0)),Y(6)=+$P(Y,U,6) Q:'Y(6) "RTN","RASTEXT",10,0) . I $D(RACCESS(DUZ,"LOC",+X)),(Y(6)=+$O(^RA(79.2,"B",RAIMGTY,0))),($D(RACCESS(DUZ,"DIV",+RAMDIV,X))) D "RTN","RASTEXT",11,0) .. S RATOTAL=RATOTAL+1,RATEMP=$P($G(^SC(+$P(Y,"^"),0)),"^")_"^"_X "RTN","RASTEXT",12,0) .. Q "RTN","RASTEXT",13,0) . Q "RTN","RASTEXT",14,0) I 'RATOTAL D D Q QUIT "RTN","RASTEXT",15,0) . W !?5,"Your access to Imaging Locations is nonexistent." "RTN","RASTEXT",16,0) . W !?5,"Contact your ADPAC for further assistance." "RTN","RASTEXT",17,0) . Q "RTN","RASTEXT",18,0) W !!?5,"Current Division: ",$P(^DIC(4,+RAMDIV,0),U,1) "RTN","RASTEXT",19,0) W !?5,"Current Imaging Type: ",RAIMGTY,! "RTN","RASTEXT",20,0) I RATOTAL=1 D "RTN","RASTEXT",21,0) . N DIR,DIROUT,DIRUT,DTOUT,DUOUT S DIR(0)="E" D ^DIR "RTN","RASTEXT",22,0) . S:'+Y RAXIT=1 Q:RAXIT "RTN","RASTEXT",23,0) . S ^TMP($J,"RADLOCS",$P(RATEMP,"^"),$P(RATEMP,"^",2))="" "RTN","RASTEXT",24,0) . S RADLOCS($P(RATEMP,"^"),$P(RATEMP,"^",2))="",RAQUIT=0 "RTN","RASTEXT",25,0) . Q "RTN","RASTEXT",26,0) I RAXIT D Q QUIT "RTN","RASTEXT",27,0) K X,Y I RATOTAL>1 D "RTN","RASTEXT",28,0) . N RAARRY,RADIC,RAUTIL "RTN","RASTEXT",29,0) . S RADIC="^RA(79.1,",(RAARRY,RAUTIL)="RADLOCS",RADIC(0)="QEAFMZ" "RTN","RASTEXT",30,0) . S RADIC("A")="Select the Location(s) you wish to track: " "RTN","RASTEXT",31,0) . S RADIC("B")="All" "RTN","RASTEXT",32,0) . S RADIC("S")="I $D(RACCESS(DUZ,""DIV"",+RAMDIV,+Y)),(+$P(^(0),""^"",6)=+$O(^RA(79.2,""B"",RAIMGTY,0)))" "RTN","RASTEXT",33,0) . D EN1^RASELCT(.RADIC,RAUTIL,RAARRY) "RTN","RASTEXT",34,0) . Q "RTN","RASTEXT",35,0) I +$G(RAQUIT) D Q Q "RTN","RASTEXT",36,0) K ^TMP($J,"RADLOCS") "RTN","RASTEXT",37,0) S RAIMGTYI=$O(^RA(79.2,"B",RAIMGTY,0)) G Q:'RAIMGTYI "RTN","RASTEXT",38,0) ; set up RASEQARR(order seq)=ien of file 72 "RTN","RASTEXT",39,0) ; if order seq is null, set it to -1, -2, etc., so each img typ gets "RTN","RASTEXT",40,0) ; gets a different negative subscript to represent a null order seq "RTN","RASTEXT",41,0) S X=0 F S X=$O(^RADPT("AS",X)) Q:X'=+X I $P($G(^RA(72,X,0)),U,7)=RAIMGTYI,$P(^(0),U,5)="Y" S RAX=$P(^(0),U,3) D:RAX="" S RASEQARR(RAX)=X "RTN","RASTEXT",42,0) . S RAX=$O(RASEQARR("")) "RTN","RASTEXT",43,0) . I RAX>0 S RAX=-1 Q "RTN","RASTEXT",44,0) . S:RAX<0 RAX=RAX-1 "RTN","RASTEXT",45,0) S RAORD="" "RTN","RASTEXT",46,0) F K ^TMP($J,"RASTEXT") S RAORD=$O(RASEQARR(RAORD)) Q:RAORD=""!(RAORD>8) S RASTAT=RASEQARR(RAORD) I $D(^RA(72,+RASTAT,0)),$P(^(0),"^",5)="Y" D START I RACTR S RACTR=0 D SCRN Q:RAQ "RTN","RASTEXT",47,0) I 'RACTR&('$D(RADTI)) W *7,!,"No incomplete statuses on file" "RTN","RASTEXT",48,0) G Q "RTN","RASTEXT",49,0) START S (RACTR,RAQ)=0 F RADFN=0:0 S RADFN=$O(^RADPT("AS",RASTAT,RADFN)) Q:RADFN'>0 F RADTI=0:0 S RADTI=$O(^RADPT("AS",RASTAT,RADFN,RADTI)) Q:RADTI'>0 I $D(^RADPT(RADFN,"DT",RADTI,0)) S Y=^(0) D GETCN "RTN","RASTEXT",50,0) Q "RTN","RASTEXT",51,0) GETCN Q:'$D(^RA(79.1,+$P(Y,"^",4),0)) ;If imaging loc is broken pointer "RTN","RASTEXT",52,0) Q:'$D(RADLOCS($P($G(^SC(+$P($G(^RA(79.1,+$P(Y,"^",4),0)),"^"),0)),"^"))) "RTN","RASTEXT",53,0) F RACNI=0:0 S RACNI=$O(^RADPT("AS",RASTAT,RADFN,RADTI,RACNI)) Q:RACNI'>0 I $D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S Y(0)=^(0) D EXT "RTN","RASTEXT",54,0) Q "RTN","RASTEXT",55,0) EXT F RAI=1:1 Q:'$D(^TMP($J,"RASTEXT",+Y,RAI)) "RTN","RASTEXT",56,0) S:$D(^XUSEC("RA MGR",DUZ))!(RAMDIV=+$P(Y,"^",3)) ^TMP($J,"RASTEXT",+Y,RAI)=RADFN_"^"_+Y(0)_"^"_$P(Y(0),"^",2)_"^"_$P(Y(0),"^",18),RACTR=1 "RTN","RASTEXT",57,0) Q "RTN","RASTEXT",58,0) ; "RTN","RASTEXT",59,0) SCRN D HD F RADTI=0:0 Q:RAQ!(RADTI="")!(RAXIT) S RADTI=$O(^TMP($J,"RASTEXT",RADTI)) Q:RADTI'>0 F I1=0:0 S I1=$O(^TMP($J,"RASTEXT",RADTI,I1)) Q:I1'>0!(RAXIT) D:$$LMAX HD D WRT D:$$LMAX SELECT^RASTEXT1 Q:RAQ!(RADTI'>0)!(RAXIT) "RTN","RASTEXT",60,0) Q:RAQ!(RAXIT) D:$$LMAX HD "RTN","RASTEXT",61,0) D SELECT^RASTEXT1 Q:RAQ!(RAXIT) "RTN","RASTEXT",62,0) G SCRN:RADTI=0 "RTN","RASTEXT",63,0) Q "RTN","RASTEXT",64,0) ; "RTN","RASTEXT",65,0) WRT I $P(RADTI,".")=DT S X=RADTI D TIME^RAUTL1 S RATI=X "RTN","RASTEXT",66,0) I $P(RADTI,".")'=DT S RATI=$E(RADTI,4,5)_"/"_$E(RADTI,6,7)_"/"_$E(RADTI,2,3) "RTN","RASTEXT",67,0) S RACTR=RACTR+1 "RTN","RASTEXT",68,0) N RASSAN,RACNDSP,RADFNXX,RADTIXX,RACNIXX "RTN","RASTEXT",69,0) S RADFNXX=+^TMP($J,"RASTEXT",RADTI,I1),RADTIXX=9999999.9999-RADTI "RTN","RASTEXT",70,0) S RACNIXX=I1,RASSAN=$$SSANVAL^RAHLRU1(RADFNXX,RADTIXX,RACNIXX) "RTN","RASTEXT",71,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:$P(^TMP($J,"RASTEXT",RADTI,I1),"^",2)) "RTN","RASTEXT",72,0) I $$USESSAN^RAHLRU1() D "RTN","RASTEXT",73,0) .W !,?1,RACNDSP,?18,$J(RATI,8),?27,$E($S($D(^DPT(+^TMP($J,"RASTEXT",RADTI,I1),0)):$P(^(0),"^"),1:"Unknown"),1,18),?46,$S($D(^RAMIS(71,+$P(^TMP($J,"RASTEXT",RADTI,I1),"^",3),0)):$E($P(^(0),"^"),1,25),1:"Unknown") "RTN","RASTEXT",74,0) I '$$USESSAN^RAHLRU1() D "RTN","RASTEXT",75,0) .W !,?1,$P(^TMP($J,"RASTEXT",RADTI,I1),"^",2),?10,$J(RATI,8),?20,$E($S($D(^DPT(+^TMP($J,"RASTEXT",RADTI,I1),0)):$P(^(0),"^"),1:"Unknown"),1,20),?42,$S($D(^RAMIS(71,+$P(^TMP($J,"RASTEXT",RADTI,I1),"^",3),0)):$E($P(^(0),"^"),1,25),1:"Unknown") "RTN","RASTEXT",76,0) W:$D(^RA(78.6,+$P(^TMP($J,"RASTEXT",RADTI,I1),"^",4),0)) ?72,$E($P(^(0),"^"),1,8) "RTN","RASTEXT",77,0) Q "RTN","RASTEXT",78,0) ; "RTN","RASTEXT",79,0) HD N RADIVHD,RAGENTXT "RTN","RASTEXT",80,0) S X=$H D NOW^RAUTL1 S RATIME=X,RASTOUT=$S($D(^RA(72,RASTAT,0)):$P(^(0),"^"),1:"") "RTN","RASTEXT",81,0) S RALOC(0)=$P(RAMLC,"^"),RALOC(1)=$P($G(^RA(79.1,RALOC(0),0)),"^") "RTN","RASTEXT",82,0) S RALOC=$P($G(^SC(RALOC(1),0)),"^"),RADIV=$P($G(^DIC(4,+RAMDIV,0)),"^") "RTN","RASTEXT",83,0) S RADIVHD="Division: "_RADIV "RTN","RASTEXT",84,0) S RAGENTXT="Exam Status Tracking Module" "RTN","RASTEXT",85,0) W @IOF,!?1,RAGENTXT,?39,RADIVHD "RTN","RASTEXT",86,0) W !?1,"Date : ",$E(DT,4,5),"/",$E(DT,6,7),"/",$E(DT,2,3)," ",RATIME,?39,"Status : ",RASTOUT "RTN","RASTEXT",87,0) W !?1,"Locations: " S X="" F S X=$O(RADLOCS(X)) Q:X']"" W:($X+$L(X))>IOM !?($X+5) W X W:$O(RADLOCS(X))'="" ?($X+5) "RTN","RASTEXT",88,0) I $$USESSAN^RAHLRU1() D "RTN","RASTEXT",89,0) .W !!?1,"Case #",?18,"Date",?27,"Patient",?46,"Procedure",?72,"Equip/Rm",! "RTN","RASTEXT",90,0) .W ?1,"----------------",?18,"----",?27,"-------",?46,"---------",?72,"--------" "RTN","RASTEXT",91,0) I '$$USESSAN^RAHLRU1() D "RTN","RASTEXT",92,0) .W !!?1,"Case #",?10,"Date",?20,"Patient",?42,"Procedure",?72,"Equip/Rm",! "RTN","RASTEXT",93,0) .W ?1,"------",?10,"----",?20,"-------",?42,"---------",?72,"--------" "RTN","RASTEXT",94,0) Q "RTN","RASTEXT",95,0) Q ; Kill and quit "RTN","RASTEXT",96,0) K %,%H,%W,%Y,%Y1,A,C,DIC,I,I1,ORX,POP,RACNI,RACNT,RACONTIN,RACS,RACTR,RADA,RADATE,RADFN,RADIV,RADTI,RAED,RAJ1,RAI,RAIMAGE,RALOC,RAMIS,RANODE,RAORD,RAPRIT,RAQ,RASTAT,RASTOUT,RATI,RATICTR,RATIME,RATXTLP,RAX,RAXIT,SDCLST,X,XQUIT,Y "RTN","RASTEXT",97,0) K RASEQARR "RTN","RASTEXT",98,0) K ^TMP($J,"RASTEXT"),^TMP($J,"RAEX") "RTN","RASTEXT",99,0) D KILLVAR^RAUTL2,KMV^RAUTL15 "RTN","RASTEXT",100,0) K DIOV,RAOR,X1 "RTN","RASTEXT",101,0) Q "RTN","RASTEXT",102,0) LMAX() ; "RTN","RASTEXT",103,0) Q:($Y+4)>IOSL 1 "RTN","RASTEXT",104,0) Q 0 "RTN","RASYS") 0^21^B37308956 "RTN","RASYS",1,0) RASYS ;HISC/CAH AISC/TMP-System Definition Menu ;11/13/96 14:17 "RTN","RASYS",2,0) ;;5.0;Radiology/Nuclear Medicine;**42,47**;Mar 16, 1998;Build 21 "RTN","RASYS",3,0) 1 ;;Division Parameter Set-up "RTN","RASYS",4,0) S DIC="^RA(79,",DIC(0)="AELMQ",DIC("A")="Select Division: ",DLAYGO=79 "RTN","RASYS",5,0) D ^DIC K DIC,DLAYGO I Y<0 K X,Y G Q1 "RTN","RASYS",6,0) S DA=+Y,DIE="^RA(79,",DR="[RA DIVISION PARAMETERS]",RAXIT=0 D ^DIE "RTN","RASYS",7,0) I $O(^RA(79,DA,"L",0)) D "RTN","RASYS",8,0) . D:'$D(IOF) HOME^%ZIS W @IOF S RAINC=0 "RTN","RASYS",9,0) . F S RAINC=$O(^RA(79,DA,"L",RAINC)) Q:RAINC'>0 D Q:RAXIT "RTN","RASYS",10,0) .. D EN1^RASYS1($P($G(^RA(79,DA,"L",RAINC,0)),"^")) "RTN","RASYS",11,0) .. Q "RTN","RASYS",12,0) . Q "RTN","RASYS",13,0) K %,%X,%Y,C,D0,DA,DE,DQ,DIE,DR,RAINC,RAXIT D Q1 W ! G 1 "RTN","RASYS",14,0) Q1 K D,DDC,DG,DI,DIG,DIH,DIU,DIV,DIW,DISYS,DST,DUOUT,I,J,POP "RTN","RASYS",15,0) Q "RTN","RASYS",16,0) ; "RTN","RASYS",17,0) 2 ;;Print Division Parameter List "RTN","RASYS",18,0) S DIC="^RA(79,",L=0,FLDS="[RA IMAGE DIV LIST]",BY="#DIVISION",FR="",TO="" D EN1^DIP K FR,TO,FLDS,BY,DHD Q "RTN","RASYS",19,0) ; "RTN","RASYS",20,0) 3 ;;Location Parameter Set-up "RTN","RASYS",21,0) S DIC="^RA(79.1,",DIC(0)="AELMQZ",DIC("A")="Select Location: ",DLAYGO=79.1 "RTN","RASYS",22,0) D ^DIC K DIC,DLAYGO I Y<0 D KILL3 Q ; DIC(0)="AELMQZ" patch 42 'Z' added "RTN","RASYS",23,0) I $P(Y,U,3)=1 W !!," * Since you have added a new Imaging Location, remember to assign * ",!," * it to a Rad/Nuc Med division through Division Parameter Set-up. * ",! "RTN","RASYS",24,0) W:$P(Y,U,3)'=1 ! W !,"Imaging Location: ",Y(0,0) ; patch 42 "RTN","RASYS",25,0) S DA=+Y,DIE="^RA(79.1,",DR="[RA LOCATION PARAMETERS]",RAXIT=0 D ^DIE "RTN","RASYS",26,0) D:'$D(IOF) HOME^%ZIS W @IOF D EN1^RASYS1(DA) D KILL3 W ! G 3 "RTN","RASYS",27,0) KILL3 K %,%X,%W,%Y,D,E,DE,DA,D0,RAREQPRT,DIE,DIV,DQ,DR,RAFLH,RAJAC,RARPT,RAXIT,X,Y "RTN","RASYS",28,0) K C,DDH,DI,DIG,DIH,DISYS,DIU,DIW,DIWI,I,POP,RALERT,RALINE "RTN","RASYS",29,0) Q "RTN","RASYS",30,0) ; "RTN","RASYS",31,0) 4 ;;Imaging Location Parameter List "RTN","RASYS",32,0) N RAINA S RAINA=0 K DIR,DIROUT,DIRUT,DTOUT,DUOUT "RTN","RASYS",33,0) S DIR(0)="Y",DIR("B")="No" "RTN","RASYS",34,0) S DIR("A")="Do you wish to include inactive Imaging Locations" "RTN","RASYS",35,0) S DIR("?",1)="Enter 'Yes' if inactive Imaging Locations are to be" "RTN","RASYS",36,0) S DIR("?")="included, 'No' if only active locations are desired." "RTN","RASYS",37,0) D ^DIR S:$D(DIRUT) RAINA=-1 "RTN","RASYS",38,0) K DIR,DIROUT,DIRUT,DTOUT,DUOUT G:RAINA<0 KILL "RTN","RASYS",39,0) S RAINA=Y ; 1 if inactives are included, 0 if only actives included "RTN","RASYS",40,0) N RAX,RAY S RAX=$$LOC^RAUTL12(RAINA) G:'RAX KILL "RTN","RASYS",41,0) S RAY="Rad/Nuc Med Imaging Location Parameter List" "RTN","RASYS",42,0) S DIC="^RA(79.1,",BY="[RA IMAGE LOC LIST]",L=0 "RTN","RASYS",43,0) S DIS(0)="I $$INA^RASYS(D0)" "RTN","RASYS",44,0) S RAPOP=$$ZIS(RAY) "RTN","RASYS",45,0) I +RAPOP D HOME^%ZIS,KILL Q "RTN","RASYS",46,0) I +$P(RAPOP,"^",2) D KILL Q ; Q'ed off in ZIS subroutine "RTN","RASYS",47,0) E D ENTASK ; not queued, to run now "RTN","RASYS",48,0) Q "RTN","RASYS",49,0) ; "RTN","RASYS",50,0) 5 ;;Camera/Equip/Room Entry/Edit "RTN","RASYS",51,0) S DIC="^RA(78.6,",DIC(0)="AELMQ",DIC("A")="Select Camera/Equip/Room: ",DLAYGO=78.6 D ^DIC K DIC,DLAYGO I Y<0 K X,Y D KILL5 Q "RTN","RASYS",52,0) S DA=+Y,DIE="^RA(78.6,",DR=".01:99" D ^DIE K %,D0,DA,DE,DQ,DIE,DR,X,Y D KILL5 W ! G 5 "RTN","RASYS",53,0) KILL5 K D,DG,DI,DISYS,I,POP Q "RTN","RASYS",54,0) ; "RTN","RASYS",55,0) 6 ;;List of Camera/Equip/Rooms "RTN","RASYS",56,0) S DIC="^RA(79.1,",L=0,BY="[RA EXAM ROOM LIST]" "RTN","RASYS",57,0) S DIOEND="D NOLOC^RASYS" D EN1^DIP "RTN","RASYS",58,0) K DIOEND,FLDS,BY,DHD,TO,FR,RANOLOC,POP "RTN","RASYS",59,0) Q "RTN","RASYS",60,0) ENTASK ; Entry point for the tasked job. "RTN","RASYS",61,0) S RAIOP=ION_";"_IOST_";"_IOM_";"_IOSL,IOP=RAIOP "RTN","RASYS",62,0) S:$E(IOP,1,3)="HFS" %ZIS("HFSNAME")=IO,%ZIS("HFSMODE")="W" "RTN","RASYS",63,0) D EN1^DIP "RTN","RASYS",64,0) D KILL^RASYS "RTN","RASYS",65,0) Q "RTN","RASYS",66,0) INA(RAD0) ; Determine if an Imaging Location is inactive. "RTN","RASYS",67,0) ; Input : 'RAD0' ien of file 79.1 "RTN","RASYS",68,0) ; Output: '1' if the location is valid, '0' if invalid "RTN","RASYS",69,0) N RA791 S RA791=$G(^RA(79.1,D0,0)) "RTN","RASYS",70,0) S RA791(1)=$$XTERNAL^RAUTL5($P(RA791,"^"),$P($G(^DD(79.1,.01,0)),"^",2)) "RTN","RASYS",71,0) Q:'($D(^TMP($J,"RA L-TYPE",RA791(1),D0))#2) 0 ; not user selected "RTN","RASYS",72,0) Q 1 "RTN","RASYS",73,0) KILL ; Kill and quit "RTN","RASYS",74,0) K ^TMP($J,"RA L-TYPE"),%X,%XX,%Y,%YY "RTN","RASYS",75,0) K %ZIS,BY,DHD,DIC,DIS,DTOUT,DUOUT,FLDS,FR,L,POP,RAIOP,RAINA,RAPOP,TO "RTN","RASYS",76,0) K X,Y,ZTDESC,ZTRTN,ZTSAVE,POP,I "RTN","RASYS",77,0) Q "RTN","RASYS",78,0) NOLOC ;print camera/equip/rm's not assigned to any imaging loc "RTN","RASYS",79,0) I $D(RANOLOC) Q "RTN","RASYS",80,0) N R1,R2,R3,RACAM,R4 S R4=0 "RTN","RASYS",81,0) S R1=0 F S R1=$O(^RA(78.6,R1)) Q:'R1 S RACAM(R1)="" "RTN","RASYS",82,0) S R2=0 F S R2=$O(^RA(79.1,R2)) Q:'R2 S R3=0 F S R3=$O(^RA(79.1,R2,"R",R3)) Q:'R3 D "RTN","RASYS",83,0) . S R1=$G(^RA(79.1,R2,"R",R3,0)) "RTN","RASYS",84,0) . K RACAM(R1) "RTN","RASYS",85,0) S R1=0 F S R1=$O(RACAM(R1)) W:'R1 # Q:'R1 D "RTN","RASYS",86,0) . W:R4 ! S R4=1 W ?3,$E($P(^RA(78.6,R1,0),U),1,15),?20,"**UNASSIGNED**",?45,"**UNASSIGNED**" "RTN","RASYS",87,0) S RANOLOC=1 Q "RTN","RASYS",88,0) INACT ; write inactive flag, called by 'List of Camera/Equip/Rms' option "RTN","RASYS",89,0) Q:$G(DDDD0)="" "RTN","RASYS",90,0) N RA1,RA2 S RA1=$O(^RA(78.6,"B",DDDD0,0)),RA2=0 "RTN","RASYS",91,0) I RA1 I $G(^RA(78.6,RA1,0))]"",$P(^(0),U,3)]"" S RA2=1 "RTN","RASYS",92,0) W ?0,$S(RA2:"(*)",1:" "),$E(DDDD0,1,15) "RTN","RASYS",93,0) Q "RTN","RASYS",94,0) ZIS(RA) ; Select a device. "RTN","RASYS",95,0) ; 'RAPOP'=device selection successful (1:no) ^ '^%ZTLOAD' called (1:yes) "RTN","RASYS",96,0) K %ZIS,IOP S %ZIS="NMQ" "RTN","RASYS",97,0) W ! S %ZIS("A")="DEVICE: " D ^%ZIS "RTN","RASYS",98,0) S RAPOP=POP_"^" "RTN","RASYS",99,0) I '+RAPOP,($D(IO("Q"))) D "RTN","RASYS",100,0) . K IO("Q") S ZTDESC=RA,ZTRTN="ENTASK^RASYS" "RTN","RASYS",101,0) . D ZTSAVE,^%ZTLOAD S $P(RAPOP,"^",2)=1 "RTN","RASYS",102,0) . I +$G(ZTSK) W !?3,"Request Queued, Task #: ",$G(ZTSK) "RTN","RASYS",103,0) . D HOME^%ZIS "RTN","RASYS",104,0) . Q "RTN","RASYS",105,0) Q RAPOP "RTN","RASYS",106,0) ZTSAVE ; Save off variables for the tasked job. "RTN","RASYS",107,0) N I F I="BY","DIC","FLDS","FR","L","RAINA","TO" S ZTSAVE(I)="" "RTN","RASYS",108,0) S:($D(DIS)\10) ZTSAVE("DIS(")="" "RTN","RASYS",109,0) S:($D(DHD)#2) ZTSAVE("DHD")="" "RTN","RASYS",110,0) S:($D(^TMP($J,"RA L-TYPE"))\10) ZTSAVE("^TMP($J,""RA L-TYPE"",")="" "RTN","RASYS",111,0) Q "RTN","RASYS",112,0) RDEV ; Select a Resource Device for a division. This subroutine is linked "RTN","RASYS",113,0) ; directly to the option: RA RESOURCE DEVICE. This option is a menu "RTN","RASYS",114,0) ; item under the RA SITEMANAGER menu option. "RTN","RASYS",115,0) N %,%X,%Y,C,D,D0,DA,DDER,DDH,DI,DIC,DIE,DQ,DR,X,Y S (DIC,DIE)="^RA(79," "RTN","RASYS",116,0) S DIC(0)="QEAMZ",DIC("A")="Select a Rad/Nuc Med Division: " D ^DIC "RTN","RASYS",117,0) G:Y'>0 QRDEV S DA=+Y,DR="D RDEVHLP^RASYS;100" D ^DIE "RTN","RASYS",118,0) QRDEV K DISYS,DST,I,POP "RTN","RASYS",119,0) Q "RTN","RASYS",120,0) RDEVHLP ; Display the Description Text for the Resource Device (#100) field "RTN","RASYS",121,0) ; on the Rad/Nuc Med Division file. "RTN","RASYS",122,0) N RA100DES,Z S Z=0 D FIELD^DID(79,100,"","DESCRIPTION","RA100DES") "RTN","RASYS",123,0) Q:'$D(RA100DES("DESCRIPTION")) W ! "RTN","RASYS",124,0) F S Z=$O(RA100DES("DESCRIPTION",Z)) Q:Z'>0 D "RTN","RASYS",125,0) . W !,$G(RA100DES("DESCRIPTION",Z)) "RTN","RASYS",126,0) . Q "RTN","RASYS",127,0) W ! "RTN","RASYS",128,0) Q "RTN","RASYS",129,0) ; "RTN","RASYS",130,0) SACNPAR ; Site (long) Accession Number Parameter Entry/Edit "RTN","RASYS",131,0) ;W !!?3,"Warning: Editing the 'USE SITE ACCESSION NUMBER?' field on a record" "RTN","RASYS",132,0) ;W !?3,"in the RAD/NUC MED DIVISION file may lead to the instability of the" "RTN","RASYS",133,0) ;W !?3,"VistA RADIOLOGY/NUCLEAR MEDICINE application.",! "RTN","RASYS",134,0) W !!?3,"Warning: Turning on the Site Specific Accession Number should only" "RTN","RASYS",135,0) W !?3,"be done in conjunction with using the RA v2.4 messaging protocols." "RTN","RASYS",136,0) W !!?3,"NOTE: Changing the Site Specific Accession Number parameter at a" "RTN","RASYS",137,0) W !?3,"multidivisional site will change the parameter for ALL divisions." "RTN","RASYS",138,0) ;K DIC S DIC(0)="AEMQZ",DIC("A")="Select Facility to Edit: " "RTN","RASYS",139,0) ;S DIC="^RA(79," D ^DIC "RTN","RASYS",140,0) ;I $D(DTOUT)!($D(DUOUT))!(Y=-1) D END Q "RTN","RASYS",141,0) N RAVAL S RAVAL=$O(^RA(79,0)),RAVAL=$P($G(^RA(79,RAVAL,.1)),"^",31) "RTN","RASYS",142,0) W !!,"Current value of Site Specific Accession Number parameter: ",$S(RAVAL="Y":"YES",1:"NO") "RTN","RASYS",143,0) S DIR(0)="YA",DIR("A")="Use Site Specific Accession Number? " D ^DIR "RTN","RASYS",144,0) S DIR("?")="Answer 'YES' to turn on use of the Site Specific Accession Number or 'NO' to turn it off." "RTN","RASYS",145,0) Q:$D(DIRUT) "RTN","RASYS",146,0) N RAZVAL S RAZVAL="N" I Y=1 S RAZVAL="Y" "RTN","RASYS",147,0) F RAZZDIV=0:0 S RAZZDIV=$O(^RA(79,RAZZDIV)) Q:RAZZDIV'>0 D "RTN","RASYS",148,0) .S (DA,RADA)=+RAZZDIV,DR=".131////^S X=RAZVAL",DIE="^RA(79," "RTN","RASYS",149,0) .D ^DIE "RTN","RASYS",150,0) Q "RTN","RASYS",151,0) END ; "RTN","RASYS",152,0) K DA,DIC,DIE,DR,DTOUT,DUOUT,RADA,X,Y "RTN","RASYS",153,0) Q "RTN","RASYS",154,0) ; "RTN","RAUTL1") 0^58^B56859744 "RTN","RAUTL1",1,0) RAUTL1 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Utility Routine ;10/22/97 13:54 "RTN","RAUTL1",2,0) ;;5.0;Radiology/Nuclear Medicine;**5,9,18,71,82,84,94,47**;Mar 16, 1998;Build 21 "RTN","RAUTL1",3,0) ;last modification by SS for P18 June 19,00 "RTN","RAUTL1",4,0) ;07/28/2008 BAY/KAM RA*5*94 Remove patch 81 from 2nd line of routine "RTN","RAUTL1",5,0) ;02/10/2006 BAY/KAM RA*5*71 Add ability to update exam data to V/R "RTN","RAUTL1",6,0) ; "RTN","RAUTL1",7,0) ;Integration Agreements "RTN","RAUTL1",8,0) ;---------------------- "RTN","RAUTL1",9,0) ;DIC(10006); DIE(10018); FILE^DIE(2053); UPDATE^DIE(2053); EN^ORB3(1362); NOTE^ORX3(868) "RTN","RAUTL1",10,0) ; "RTN","RAUTL1",11,0) I "IOSCR"'[X!(X="") S X="Unknown" Q "RTN","RAUTL1",12,0) G @($E(X)) "RTN","RAUTL1",13,0) ;Set X=Inpatient Location "RTN","RAUTL1",14,0) I S X=$S($D(^DIC(42,+$P(^RADPT(D0,"DT",D1,"P",D2,0),"^",6),0)):$P(^(0),"^"),1:"Unknown") "RTN","RAUTL1",15,0) Q "RTN","RAUTL1",16,0) ; "RTN","RAUTL1",17,0) ;Set X=Outpatient Location "RTN","RAUTL1",18,0) O S X=$S($D(^SC(+$P(^RADPT(D0,"DT",D1,"P",D2,0),"^",8),0)):$P(^(0),"^"),1:"Unknown") "RTN","RAUTL1",19,0) Q "RTN","RAUTL1",20,0) ; "RTN","RAUTL1",21,0) ;Set X=Contract/Sharing Agreement patient location "RTN","RAUTL1",22,0) S ; "RTN","RAUTL1",23,0) C S X=$S($D(^DIC(34,+$P(^RADPT(D0,"DT",D1,"P",D2,0),"^",9),0)):$P(^(0),"^"),1:"Unknown") "RTN","RAUTL1",24,0) Q "RTN","RAUTL1",25,0) ; "RTN","RAUTL1",26,0) ;Set X=Research patient location "RTN","RAUTL1",27,0) R S X=$S($D(^RADPT(D0,"DT",D1,"P",D2,"R")):$P(^("R"),"^"),1:"Unknown") Q "RTN","RAUTL1",28,0) ; "RTN","RAUTL1",29,0) ;Set X=time of day in external format (ex: 2:28 PM) "RTN","RAUTL1",30,0) NOW S %=$P($H,",",2),X=DT_(%\60#60/100+(%\3600)+(%#60/10000)/100) D TIME "RTN","RAUTL1",31,0) Q "RTN","RAUTL1",32,0) ;Input X=FM date/time, Output X=time (external format) "RTN","RAUTL1",33,0) TIME S X=$E($P(X,".",2)_"0000",1,4),%=X>1159 S:X>1259 X=X-1200 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M" S:$P(X,":")=0 X=12_":"_$P(X,":",2) "RTN","RAUTL1",34,0) Q "RTN","RAUTL1",35,0) ; "RTN","RAUTL1",36,0) ELAPSED ;Pass parameters X (from date) and X1 (to date) "RTN","RAUTL1",37,0) ;Variable Y is returned as either an elapsed time in the form DD:HH:MM where DD=days, HH=hours, MM=minutes or as the string 'Neg. Time' indicating a negative elapsed time "RTN","RAUTL1",38,0) ;Variable Y1 is returned as the # of minutes of elapsed time "RTN","RAUTL1",39,0) I '$D(RAMTIME) S DIC="^DD(""FUNC"",",DIC(0)="FX",RAX=X,X="MINUTES" D ^DIC K DIC S X=RAX S:$D(^DD("FUNC",+Y,1)) RAMTIME=^(1) I '$D(RAMTIME) W $C(7),!!,"Can't continue --- No 'MINUTES' function found in File Manager" K Y,Y1 G Q "RTN","RAUTL1",40,0) X RAMTIME S Y1=X I X<0 S Y="Neg. Time" G Q "RTN","RAUTL1",41,0) MINUTS S X(1)=X\1440,X=X-(1440*X(1)),X(2)=X\60,X(3)=X-(60*X(2)),Y=$E(100+X(1),2,3)_":"_$E(100+X(2),2,3)_":"_$E(100+X(3),2,3) "RTN","RAUTL1",42,0) Q K RAX,X Q "RTN","RAUTL1",43,0) ; "RTN","RAUTL1",44,0) UPDATE ;Entry point for Update Rad/Nuc Med Exam Status option "RTN","RAUTL1",45,0) I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0) "RTN","RAUTL1",46,0) I $G(RAIMGTY)="" D SETVARS^RAPSET1(1) "RTN","RAUTL1",47,0) I $G(RAIMGTY)="" K XQUIT Q ; didn't sign-on to an imaging location "RTN","RAUTL1",48,0) D ^RACNLU G UPQ:"^"[X "RTN","RAUTL1",49,0) I $D(^RA(72,"AA",RAIMGTY,9,+RAST)),'$D(^XUSEC("RA MGR",DUZ)) W !!?3,$C(7),"You do not have the appropriate access privileges to act on completed exams." G UPDATE "RTN","RAUTL1",50,0) I $D(^RA(72,"AA",RAIMGTY,0,+RAST)) W !!?3,$C(7),"Exam has been 'cancelled' therefore the status cannot be changed." G UPDATE "RTN","RAUTL1",51,0) ;D UP1 I RAOR>0 S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"",",DR="100///""NOW""",DR(2,70.07)="2///U;3////"_$S($G(RADUZ):RADUZ,1:DUZ) D ^DIE "RTN","RAUTL1",52,0) D UP1 I RAOR>0 D "RTN","RAUTL1",53,0) .L +^RADPT(RADFN,"DT",RADTI,"P",RACNI):$G(DILOCKTM,3) "RTN","RAUTL1",54,0) .N RAIEN "RTN","RAUTL1",55,0) .S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_"," "RTN","RAUTL1",56,0) .S RAFDA(70.07,RAIENS,.01)="NOW" "RTN","RAUTL1",57,0) .K RAERR D UPDATE^DIE("E","RAFDA","RAIEN","RAERR") "RTN","RAUTL1",58,0) .K RAFDA,RAIENS "RTN","RAUTL1",59,0) .I $D(RAERR) S RAERR="Error in update of 70.07, .01 "_$G(RAERR("DIERR",1,"TEXT",1)) K RAERR("DIERR") L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) K RAIEN Q "RTN","RAUTL1",60,0) .S RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_"," "RTN","RAUTL1",61,0) .S RAFDA(70.07,RAIENS,2)="U" "RTN","RAUTL1",62,0) .S RAFDA(70.07,RAIENS,3)=$S($G(RADUZ):RADUZ,1:DUZ) "RTN","RAUTL1",63,0) .D FILE^DIE(,"RAFDA","RAERR") "RTN","RAUTL1",64,0) .L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) "RTN","RAUTL1",65,0) .I $D(RAERR) S RAERR="Error in update of 70.07, 2,3 "_$G(RAERR("DIERR",1,"TEXT",1)) K RAERR("DIERR") "RTN","RAUTL1",66,0) UPQ K RAFDA,RAIENS "RTN","RAUTL1",67,0) K %,D,DA,DE,DIC,DIE,DQ,DR,I,J,POP,RACS,RAEND,RAF5,RAFL,RAFST,RAI,RAIX,RAJ1,RAORDIFN,RAPRIT,RAHEAD,RASN,RAOR,RASTI,RASSN,RADATE,RAST,RACN,RACNI,RADFN,RADTE,RADTI,RANME,RAPRC,RARPT,X,Y,Z,^TMP($J,"RAEX"),C,DIPGM Q "RTN","RAUTL1",68,0) ; "RTN","RAUTL1",69,0) ;Exam status updating and accompanying updates to status log, oe/rr "RTN","RAUTL1",70,0) UP1 N RA8,RAEXEDT S RA8=0 ;use this to flag when one alert has been sent "RTN","RAUTL1",71,0) ;Line change for RA*5*82 "RTN","RAUTL1",72,0) S RAEXEDT=$$CMPAFTR^RAO7XX(1) ;P18 if procedure changed in RAEDCN or RAEDPT sends XX message to CPRS if needed "RTN","RAUTL1",73,0) ; RA EDITCN and RA EDITPT should process this case only "RTN","RAUTL1",74,0) I $D(RAOPT("EDITCN"))!($D(RAOPT("EDITPT"))) D UP2,UPK Q "RTN","RAUTL1",75,0) ; see if this case belongs to a printset "RTN","RAUTL1",76,0) N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR "RTN","RAUTL1",77,0) D EN2^RAUTL20(.RAMEMARR) ;043099 always recalculate RAPRTSET "RTN","RAUTL1",78,0) ; if not print set, then just process this case only "RTN","RAUTL1",79,0) I 'RAPRTSET D UP2,UPK Q "RTN","RAUTL1",80,0) ;case belongs to print set, so process all members of same print set "RTN","RAUTL1",81,0) N RACNISAV,RA7 "RTN","RAUTL1",82,0) S RACNISAV=RACNI,RA7=0 "RTN","RAUTL1",83,0) F S RA7=$O(RAMEMARR(RA7)) Q:RA7="" S RACNI=RA7 D UP2 "RTN","RAUTL1",84,0) S RACNI=RACNISAV "RTN","RAUTL1",85,0) G UPK "RTN","RAUTL1",86,0) UP2 ;Remedy Call 124379 Patch *71 BAY/KAM Added next line "RTN","RAUTL1",87,0) ;Patch RA*5*82 next line commented out "RTN","RAUTL1",88,0) ;D:$G(RAHLTCPB)'=1 EXM^RAHLRPC "RTN","RAUTL1",89,0) ; "RTN","RAUTL1",90,0) S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P""," "RTN","RAUTL1",91,0) N RAAFTER,RABEFORE "RTN","RAUTL1",92,0) D STUFF^RASTREQ1 I RAOR<0,$D(RASN) W:'$D(RAONLINE)&('$D(ZTQUEUED)) !?5,"...exam status remains '",RASN,"'." K DIE,RACS,RAPRIT D Q "RTN","RAUTL1",93,0) .D:$G(RAEXEDT) EXM^RAHLRPC ; DO statement added by RA*5*82 "RTN","RAUTL1",94,0) ;W:'$D(RAONLINE)&('$D(ZTQUEUED)) !?3,"...will now designate exam status as '",RASN,"'... for case no. ",$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U) "RTN","RAUTL1",95,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RAUTL1",96,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U)) "RTN","RAUTL1",97,0) I $$USESSAN^RAHLRU1() W:'$D(RAONLINE)&('$D(ZTQUEUED)) !?3,"...will now designate exam status as '",RASN,"'",!?25,"...for case no. ",RACNDSP "RTN","RAUTL1",98,0) I '$$USESSAN^RAHLRU1() W:'$D(RAONLINE)&('$D(ZTQUEUED)) !?3,"...will now designate exam status as '",RASN,"'... for case no. ",$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U) "RTN","RAUTL1",99,0) ; S DR="3////"_RASTI_$S($P(RAMDV,"^",10):";75///^S X=$$MIDNGHT^RAUTL5($$NOW^XLFDT())",1:"") "RTN","RAUTL1",100,0) ; user duz could be in RADUZ, if session is from the Voice recognition "RTN","RAUTL1",101,0) ;S DR(2,70.05)=$S($P(RAMDV,"^",11)&('$D(ZTQUEUED)):".01;",1:"")_"2////"_RASTI_";3////"_$S($G(RADUZ):RADUZ,1:DUZ) "RTN","RAUTL1",102,0) ;D ^DIE "RTN","RAUTL1",103,0) L +^RADPT(RADFN,"DT",RADTI,"P",RACNI):$G(DILOCKTM,3) "RTN","RAUTL1",104,0) N RAIEN "RTN","RAUTL1",105,0) S RAIENS=RACNI_","_RADTI_","_RADFN_"," "RTN","RAUTL1",106,0) S RAFDA(70.03,RAIENS,3)=RASTI "RTN","RAUTL1",107,0) K RAERR D FILE^DIE(,"RAFDA","RAERR") "RTN","RAUTL1",108,0) I $D(RAERR) S RAERR="Error in update of 70.03 "_$G(RAERR("DIERR",1,"TEXT",1)) K RAERR("DIERR") L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) G UP2K ;L - P18 "RTN","RAUTL1",109,0) I $P(RAMDV,"^",10) D "RTN","RAUTL1",110,0) .N RAERR2 "RTN","RAUTL1",111,0) .S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_"," "RTN","RAUTL1",112,0) .S RAFDA(70.05,RAIENS,.01)=$$MIDNGHT^RAUTL5($$NOW^XLFDT()) "RTN","RAUTL1",113,0) .D UPDATE^DIE(,"RAFDA","RAIEN","RAERR") "RTN","RAUTL1",114,0) .K RAFDA,RAIENS "RTN","RAUTL1",115,0) .I $D(RAERR) S RAERR="Error in update of 70.05, .01 "_$G(RAERR("DIERR",1,"TEXT",1)) K RAERR("DIERR") "RTN","RAUTL1",116,0) .Q:'$D(RAIEN(1)) "RTN","RAUTL1",117,0) .I $P(RAMDV,"^",11),('$D(ZTQUEUED)) D "RTN","RAUTL1",118,0) ..S DIE=DIE_RACNI_",""T"",",DA=RAIEN(1) "RTN","RAUTL1",119,0) ..S DR=".01" "RTN","RAUTL1",120,0) ..D ^DIE "RTN","RAUTL1",121,0) .S RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_"," "RTN","RAUTL1",122,0) .S RAFDA(70.05,RAIENS,2)=RASTI "RTN","RAUTL1",123,0) .S RAFDA(70.05,RAIENS,3)=$S($G(RADUZ):RADUZ,1:DUZ) "RTN","RAUTL1",124,0) .K RAERR2 D FILE^DIE(,"RAFDA","RAERR2") "RTN","RAUTL1",125,0) .I $D(RAERR2) S RAERR2="Error in update of 70.05 2,3 "_$G(RAERR2("DIERR",1,"TEXT",1)),RAERR=$S($D(RAERR):RAERR_";"_RAERR2,1:RAERR2) "RTN","RAUTL1",126,0) ;Patch RA*5*82 added next line send EXM message after status update, not before the update "RTN","RAUTL1",127,0) D:'$D(RAERR) EXM^RAHLRPC "RTN","RAUTL1",128,0) L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) "RTN","RAUTL1",129,0) ; "RTN","RAUTL1",130,0) UP2K K DE,DQ,DIE,DR,RAFDA,RAIENS K:$D(RAERR) RACS,RAPRIT Q:$D(RAERR) W:'$D(RAONLINE)&('$D(ZTQUEUED)) !?10,"...exam status ",$S($G(RABEFORE)>$G(RAAFTER):"backed down",1:"successfully updated"),"." D ^RAORDC "RTN","RAUTL1",131,0) I RA8=0,$D(^RA(72,RASTI,"ALERT")),$P(^("ALERT"),"^")="y" D:$$ORVR^RAORDU()=2.5 OERR D:$$ORVR^RAORDU()'<3 OERR3 S RA8=1 "RTN","RAUTL1",132,0) I $D(^RA(72,RASTI,0)),$P(^(0),"^",3)>1,RACS'="Y",$S('$D(RAF5):1,$P(^DIC(42,+RAF5,0),U,3)="D":1,1:0) D EN^RAUTL0 "RTN","RAUTL1",133,0) K RACS,RAORDIFN,RAPRIT,RAF5 "RTN","RAUTL1",134,0) Q "RTN","RAUTL1",135,0) UPK K ORIFN,ORVP,ORNOTE,ORBPMSG,RACS,RAORDIFN,RAPRIT,RAF5 "RTN","RAUTL1",136,0) Q "RTN","RAUTL1",137,0) OERR ;Send Alert to OERR after pt examined "RTN","RAUTL1",138,0) S ORVP=RADFN_";DPT(",ORBPMSG="Rad Pt Examined - "_$S($D(^RAMIS(71,RAPRIT,0)):$E($P(^(0),"^"),1,24),1:"Unknown") S:$D(^RAO(75.1,+RAORDIFN,0)) ORIFN=+$P(^(0),"^",7) S ORNOTE(21)=$S($D(ORIFN):1,1:"") D NOTE^ORX3 "RTN","RAUTL1",139,0) Q "RTN","RAUTL1",140,0) OERR3 ; Send RADIOLOGY PATIENT EXAMINED notification via oe/rr v3 "RTN","RAUTL1",141,0) ; Called from UP1 "RTN","RAUTL1",142,0) ; "RTN","RAUTL1",143,0) ; RADFN,RADTI,RACNI,RAPRIT must be defined "RTN","RAUTL1",144,0) Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))!('$D(RAPRIT)) "RTN","RAUTL1",145,0) ; "RTN","RAUTL1",146,0) N RAIENS,RAMSG,RAOIFN,RAOSTS,RAONODE,RADPTNDE,RAREQPHY "RTN","RAUTL1",147,0) S RADPTNDE=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) "RTN","RAUTL1",148,0) S RAOIFN=$P(RADPTNDE,U,11) Q:'RAOIFN ;file 75.1 ien "RTN","RAUTL1",149,0) S RAONODE=$G(^RAO(75.1,+RAOIFN,0)) "RTN","RAUTL1",150,0) S RAOSTS=$P(RAONODE,U,5) Q:RAOSTS'=6 ;active exams only "RTN","RAUTL1",151,0) S RAOIFN=$P(RAONODE,U,7) ;file 100 ien "RTN","RAUTL1",152,0) S RAREQPHY=+$P(RADPTNDE,U,14) ;ordering provider "RTN","RAUTL1",153,0) S RAREQPHY(RAREQPHY)="" "RTN","RAUTL1",154,0) S RAMSG="Imaging Pt Examined - "_$S($D(^RAMIS(71,RAPRIT,0)):$E($P(^(0),U),1,24),1:"Unknown"),RAMSG=$E(RAMSG,1,51) "RTN","RAUTL1",155,0) S RAIENS=RADTI_"~"_RACNI "RTN","RAUTL1",156,0) ; "RTN","RAUTL1",157,0) ; oe parameters: "RTN","RAUTL1",158,0) ; ORN: notification id (#100.9 ien) "RTN","RAUTL1",159,0) ; | ORBDFN: patient id (#2 ien) "RTN","RAUTL1",160,0) ; | | ORNUM: order number (#100 ien) "RTN","RAUTL1",161,0) ; | | | ORBADUZ: recipient array "RTN","RAUTL1",162,0) ; | | | | ORBPMSG: message text "RTN","RAUTL1",163,0) ; | | | | | ORBPDATA exam dt~case iens "RTN","RAUTL1",164,0) ; | | | | | | "RTN","RAUTL1",165,0) D EN^ORB3(21,RADFN,RAOIFN,.RAREQPHY,RAMSG,RAIENS) "RTN","RAUTL1",166,0) Q "RTN","RAUTL1",167,0) ; "RTN","RAUTL1",168,0) ;Called by many report programs. Sets RACRT() array containing all "RTN","RAUTL1",169,0) ;exam statuses that are to be included on the report. RACRT is set "RTN","RAUTL1",170,0) ;to the piece of the Exam Status File #72 record that corresponds "RTN","RAUTL1",171,0) ;to the report being generated. "RTN","RAUTL1",172,0) CRIT F I=0:0 S I=$O(^RA(72,I)) Q:'I I $D(^(I,.3)),$P(^(.3),"^",RACRT)="y" S RACRT(I)="" "RTN","RAUTL1",173,0) Q "RTN","RAUTL15") 0^59^B20281413 "RTN","RAUTL15",1,0) RAUTL15 ;HISC/GJC-Skeleton rpt del if no data entered. ;11/5/99 12:33 "RTN","RAUTL15",2,0) ;;5.0;Radiology/Nuclear Medicine;**5,10,47**;Mar 16, 1998;Build 21 "RTN","RAUTL15",3,0) EN3(IEN74) ;Delete the skeleton report and pointer from Rad Pt file to "RTN","RAUTL15",4,0) ; report if user has not entered any report data (i.e. user ^'d out "RTN","RAUTL15",5,0) ; of report entry/edit after the system created a skeleton record). "RTN","RAUTL15",6,0) ; If the report is deleted, a bulletin will not be generated! "RTN","RAUTL15",7,0) N RA,RAPRG74,RATXT "RTN","RAUTL15",8,0) S RA(0)=$G(^RARPT(IEN74,0)) Q:RA(0)']"" 0 "RTN","RAUTL15",9,0) I $O(^RARPT(IEN74,2005,0))>0 Q 0 "RTN","RAUTL15",10,0) S RA("I")=$S(+$O(^RARPT(IEN74,"I",0))'>0:1,1:0) "RTN","RAUTL15",11,0) S RA("P")=$S($G(^RARPT(IEN74,"P"))="":1,1:0) "RTN","RAUTL15",12,0) S RA("R")=$S(+$O(^RARPT(IEN74,"R",0))'>0:1,1:0) "RTN","RAUTL15",13,0) S RA(5)=$P(RA(0),"^",5),RA(5)=$S(RA(5)]"":RA(5),1:"Null") "RTN","RAUTL15",14,0) I $L(RA(0),"^")'>6,("dD"[RA(5)),(RA("I")),(RA("P")),(RA("R")) D Q 1 "RTN","RAUTL15",15,0) . N %,D,D0,DA,DIC,DIE,DIK,DQ,DR,X,Y "RTN","RAUTL15",16,0) . ; +++++ Delete Report Text pointer from the Examinations +++++ "RTN","RAUTL15",17,0) . ; +++++ multiple in the Rad/Nuc Med Patient file +++++ "RTN","RAUTL15",18,0) . ; +++++ if the data is xrefed, delete xref +++++ "RTN","RAUTL15",19,0) . ; del other print member's REPORT TEXT xrefs, & set ptr to #74 as null "RTN","RAUTL15",20,0) . D DEL17^RARTE2(IEN74) "RTN","RAUTL15",21,0) . ; set RADFN, RADTI & RACNI if not defined! This situation will arise "RTN","RAUTL15",22,0) . ; when this code finds an incomplete Rad/Nuc Med Report while running "RTN","RAUTL15",23,0) . ; the post-init portion of the software. "RTN","RAUTL15",24,0) . S:'$D(RADFN) RADFN=$P(RA(0),"^",2) "RTN","RAUTL15",25,0) . S:'$D(RADTI) RADTI=9999999.9999-$P(RA(0),"^",3) "RTN","RAUTL15",26,0) . S:'$D(RACNI) RACNI=+$O(^RADPT(RADFN,"DT",RADTI,"P","B",+$P(RA(0),"^",4),0)) "RTN","RAUTL15",27,0) . S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI "RTN","RAUTL15",28,0) . D ENKILL^RAXREF(70.03,17,IEN74,.DA) "RTN","RAUTL15",29,0) . ; Delete pointers to the Rad/Nuc Med Report file i.e, '^RARPT(' "RTN","RAUTL15",30,0) . ;******* "RTN","RAUTL15",31,0) . S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)="" K DA,X "RTN","RAUTL15",32,0) . ; +++++ Delete Report pntr from the Reports multiple in +++++ "RTN","RAUTL15",33,0) . ; +++++ the Reports Batches file +++++ "RTN","RAUTL15",34,0) . ; +++++ Delete Report pntr from the Report Distribution file +++++ "RTN","RAUTL15",35,0) . D UPDTPNT^RAUTL9(IEN74) "RTN","RAUTL15",36,0) . ; +++++ Delete the entry from the Rad/Nuc Med Reports file +++++ "RTN","RAUTL15",37,0) . S DA=IEN74,DIK="^RARPT(" D ^DIK "RTN","RAUTL15",38,0) . S RATXT(1)=" " "RTN","RAUTL15",39,0) . S RATXT(2)=" Report not complete. Must Delete......deletion complete!" "RTN","RAUTL15",40,0) . S RATXT(3)=$C(7) D MES^XPDUTL(.RATXT) "RTN","RAUTL15",41,0) . Q "RTN","RAUTL15",42,0) Q 0 "RTN","RAUTL15",43,0) KMV ; kill miscellaneous variables "RTN","RAUTL15",44,0) K %DT,%I,%RET,%T "RTN","RAUTL15",45,0) K D,D0,D1,D2,D3,DA,DDER,DDH,DI,DIE,DIFLD,DIG,DIH,DISYS,DIU,DIW,DIWF,DIWL,DIWR,DIWT,DG,DK,DL,DM,DN,DR "RTN","RAUTL15",46,0) K POP "RTN","RAUTL15",47,0) Q "RTN","RAUTL15",48,0) ; "RTN","RAUTL15",49,0) CZECH(Y) ; check if an order can be cancelled, held, or scheduled. "RTN","RAUTL15",50,0) ; Y -> ien of the Rad/Nuc Med Orders file. "RTN","RAUTL15",51,0) ; Y1 -> if OE/RR > 2.5 & no order number: 1, else 0 "RTN","RAUTL15",52,0) ; Called from: VALORD subroutine "RTN","RAUTL15",53,0) N RAORDER,Y1 S Y1=0 "RTN","RAUTL15",54,0) S RAORDER(0)=$G(^RAO(75.1,+Y,0)) Q:RAORDER(0)']"" "RTN","RAUTL15",55,0) I '$P(RAORDER(0),U,7),(+$$ORVR^RAORDU()>2.5) D "RTN","RAUTL15",56,0) . N Y2 ; 'Y2' is the procedure name "RTN","RAUTL15",57,0) . S Y1=1,Y2=$P($G(^RAMIS(71,+$P(RAORDER(0),U,2),0)),U) "RTN","RAUTL15",58,0) . D INV(RAOPTN,Y2) "RTN","RAUTL15",59,0) . Q "RTN","RAUTL15",60,0) Q Y1 "RTN","RAUTL15",61,0) INV(X,X1) ; invalid action message called from the schedule/cancel or hold "RTN","RAUTL15",62,0) ; request options. "RTN","RAUTL15",63,0) ; X -> point of orgin (option) X1 -> procedure name "RTN","RAUTL15",64,0) ; Called from: CZECH subroutine "RTN","RAUTL15",65,0) S X=$$UP^XLFSTR($E(X,1,3)),X1=$S(X1]"":X1,1:"Unknown") "RTN","RAUTL15",66,0) W !!?3,"Sorry, can't "_$S(X="SCH":"schedule",X="CAN":"cancel",1:"hold") "RTN","RAUTL15",67,0) W " this request until OE/RR assigns an order number" "RTN","RAUTL15",68,0) W !?3,"for procedure: ",X1,!?3,"Please try later!" "RTN","RAUTL15",69,0) Q "RTN","RAUTL15",70,0) VALORD ; validate order data, i.e, has OE/RR order # and the site is running "RTN","RAUTL15",71,0) ; a version of OE/RR > 2.5 Called from: 2^RAORD, 3^RAORD & 4^RAORD "RTN","RAUTL15",72,0) N G1,G2,RA751 S G1=0 "RTN","RAUTL15",73,0) F S G1=$O(RAORDS(G1)) Q:G1'>0 D "RTN","RAUTL15",74,0) . S G2=$$CZECH(+$G(RAORDS(G1))) K:G2 RAORDS(G1) "RTN","RAUTL15",75,0) . Q "RTN","RAUTL15",76,0) Q "RTN","RAUTL15",77,0) DPROC(RADFN,RADTI,RACNI,RAOIFN) ; Determine if the ordered procedure is "RTN","RAUTL15",78,0) ; different from the registered procedure. "RTN","RAUTL15",79,0) ; Input Variables: RADFN-Patient DFN "RTN","RAUTL15",80,0) ; RADTI-inverse DT of exam (if exists) "RTN","RAUTL15",81,0) ; RACNI-IEN on the case node (if exists) "RTN","RAUTL15",82,0) ; RAOIFN-IEN of the order "RTN","RAUTL15",83,0) ; Output: null-procedures don't differ -OR- no order/exam "RTN","RAUTL15",84,0) ; not null-ordered proc_"^"_registered proc data "RTN","RAUTL15",85,0) ; registered procedure data includes imaging type, procedure "RTN","RAUTL15",86,0) ; type and CPT codes (if any) "RTN","RAUTL15",87,0) ; "RTN","RAUTL15",88,0) ; NOTE: The only time we don't set ^TMP($J,"RA DIFF PRC") is when "RTN","RAUTL15",89,0) ; we are using the 'Detailed Request Display' option and the ordered "RTN","RAUTL15",90,0) ; procedure is the same as the registered procedure. All other "RTN","RAUTL15",91,0) ; Request display options output the ordered procedure, the "RTN","RAUTL15",92,0) ; registered procedure and exam case number if the order "RTN","RAUTL15",93,0) ; is active. "RTN","RAUTL15",94,0) ; "RTN","RAUTL15",95,0) N RA7003,RA751 "RTN","RAUTL15",96,0) S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) "RTN","RAUTL15",97,0) S RA751=$G(^RAO(75.1,RAOIFN,0)) "RTN","RAUTL15",98,0) Q:$P(RA7003,"^",2)=""!($P(RA751,"^",2)="") "" ; missing order or xam "RTN","RAUTL15",99,0) I '$D(RAOPT("ORDERPRINTS")),'$D(RAOPT("ORDERPRINTPAT")) Q:$P(RA7003,"^",2)=$P(RA751,"^",2) "" ; except for 2 print options, quit if req.prc=regis.prc "RTN","RAUTL15",100,0) N RA71,RACPT,RACSE,RAITY,RAPRC,RATY,X,Y "RTN","RAUTL15",101,0) S RACSE=$$RJ^XLFSTR($P(RA7003,"^"),5) "RTN","RAUTL15",102,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI) "RTN","RAUTL15",103,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACSE) "RTN","RAUTL15",104,0) S RA71=$G(^RAMIS(71,$P(RA7003,"^",2),0)) "RTN","RAUTL15",105,0) S RACPT=$P($$NAMCODE^RACPTMSC(+$P(RA71,"^",9),DT),"^") "RTN","RAUTL15",106,0) S RAPRC=$E($$GET1^DIQ(71,+$P(RA7003,"^",2)_",",.01),1,36) "RTN","RAUTL15",107,0) S RAITY=$$GET1^DIQ(79.2,+$P(RA71,"^",12)_",",3) "RTN","RAUTL15",108,0) S RATY=$$GET1^DIQ(71,$P(RA7003,"^",2)_",",6) "RTN","RAUTL15",109,0) S RATY=$E(RATY,1)_$$LOW^XLFSTR($E(RATY,2,9999)) "RTN","RAUTL15",110,0) ; "RTN","RAUTL15",111,0) I $$USESSAN^RAHLRU1() S X="",Y=RACNDSP_" "_RAPRC,Y(0)="("_RAITY_" "_RATY_" "_RACPT_")" "RTN","RAUTL15",112,0) I '$$USESSAN^RAHLRU1() S X="",Y=RACSE_" "_RAPRC,Y(0)="("_RAITY_" "_RATY_" "_RACPT_")" "RTN","RAUTL15",113,0) S Y(0)=Y(0)_" "_$E($P($G(^RA(72,+$P(RA7003,"^",3),0)),"^"),1,4) "RTN","RAUTL15",114,0) S $E(X,1,42)=Y,$E(X,44,70)=Y(0) "RTN","RAUTL15",115,0) Q X "RTN","RAUTL2") 0^60^B40821700 "RTN","RAUTL2",1,0) RAUTL2 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Utility Routine ;11/10/97 11:18 "RTN","RAUTL2",2,0) ;;5.0;Radiology/Nuclear Medicine;**10,26,45,47**;Mar 16, 1998;Build 21 "RTN","RAUTL2",3,0) ; "RTN","RAUTL2",4,0) ;Called from many points within Rad/Nuc Med package ;ch "RTN","RAUTL2",5,0) ;INPUT VARIABLES: Y=IEN of Rad Report file #74 "RTN","RAUTL2",6,0) ; XRT0,XRT1 If set, will do some response time checks "RTN","RAUTL2",7,0) ;OUTPUT VARIABLES: "RTN","RAUTL2",8,0) ; RADFN=Patient DFN, RADTE=Exam date/time (FM format), "RTN","RAUTL2",9,0) ; RACN=long case number, RADTI=reverse exam date/time, "RTN","RAUTL2",10,0) ; RACNI=short case number, RADATE=Exam date/time (external format) "RTN","RAUTL2",11,0) ; Y=If active case, zeroeth node of case record in file #70 "RTN","RAUTL2",12,0) RASET ;P47 Check SSAN and use ADC or ADC1 accordingly: "RTN","RAUTL2",13,0) ;If .01 of RARPT>12 (SSAN) use "ADC1" x-ref to look up exam "RTN","RAUTL2",14,0) ;If .01 of RARPT'>12 (old CASE NO.) use "ADC" x-ref to look up exam "RTN","RAUTL2",15,0) D:$D(XRTL) T0^%ZOSV "RTN","RAUTL2",16,0) S Y=$S($D(^RARPT(+Y,0)):^(0),1:"") Q:'Y S RADFN=+$P(Y,"^",2) "RTN","RAUTL2",17,0) S RADTE=+$P(Y,"^",3),RACN=+$P(Y,"^",4),RADTI=9999999.9999-RADTE "RTN","RAUTL2",18,0) I $L($P(Y,"^"),"-")>2 S RACNI=$O(^RADPT("ADC1",$P(Y,"^"),RADFN,RADTI,0)) "RTN","RAUTL2",19,0) I $L($P(Y,"^"),"-")<3 S RACNI=$O(^RADPT("ADC",$P(Y,"^"),RADFN,RADTI,0)) "RTN","RAUTL2",20,0) S Y=RADTE D D^RAUTL S RADATE=Y "RTN","RAUTL2",21,0) ;D:$D(XRTL) T0^%ZOSV S Y=$S($D(^RARPT(+Y,0)):^(0),1:"") Q:'Y S RADFN=+$P(Y,"^",2),RADTE=+$P(Y,"^",3),RACN=+$P(Y,"^",4),RADTI=9999999.9999-RADTE,RACNI=$O(^RADPT("ADC",$P(Y,"^"),RADFN,RADTI,0)) S Y=RADTE D D^RAUTL S RADATE=Y "RTN","RAUTL2",22,0) S Y="" I RACNI,$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S Y=^(0) "RTN","RAUTL2",23,0) I $D(XRT0) S XRTN=$T(+0) D T1^%ZOSV "RTN","RAUTL2",24,0) Q "RTN","RAUTL2",25,0) ; "RTN","RAUTL2",26,0) ;Called from 2 x-refs on file #74, Rpt Status fld 5 ;ch "RTN","RAUTL2",27,0) ;Does sets and kills for 'ARES', and 'ASTF' xrefs "RTN","RAUTL2",28,0) ; ** CAUTION ** 1st RARAD=12 or 15, 2nd RARAD=ien for file 200 "RTN","RAUTL2",29,0) XREF Q:'$D(^RARPT(DA,0)) S RADFNZ=^(0),RADTIZ=9999999.9999-$P(RADFNZ,"^",3),RACNIZ=$O(^RADPT(+$P(RADFNZ,"^",2),"DT",RADTIZ,"P","B",+$P(RADFNZ,"^",4),0)),RADFNZ=+$P(RADFNZ,"^",2),RADA=DA G Q:'RACNIZ "RTN","RAUTL2",30,0) S RARADOLD=RARAD ;save 1st value of rarad "RTN","RAUTL2",31,0) G Q:'$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0)) S RARAD=+$P(^(0),"^",RARAD) G Q:'RARAD "RTN","RAUTL2",32,0) ; ** CAUTION ** next line is reached 2 ways : from line above, "RTN","RAUTL2",33,0) ; and also from file 70.03, fld 15's "ASTF" xref "RTN","RAUTL2",34,0) ; thus RARAD's 2nd meaning must be preserved for XREF1 "RTN","RAUTL2",35,0) XREF1 S:$D(RASET) ^RARPT(RAXREF,RARAD,RADA)="" K:$D(RAKILL) ^RARPT(RAXREF,RARAD,RADA) D XPRI^RAUTL20 "RTN","RAUTL2",36,0) Q K RADA,RADFNZ,RADTIZ,RACNIZ,RARADOLD Q "RTN","RAUTL2",37,0) ; "RTN","RAUTL2",38,0) ;Checks for CONTRAST MEDIA given the necessary subscripts "RTN","RAUTL2",39,0) ;to access a record in File #70. "RTN","RAUTL2",40,0) ;RADFN, RADTI, RACNI must be set. "RTN","RAUTL2",41,0) ;Output is Y=a string delimited by commas containing all "RTN","RAUTL2",42,0) ;applicable items in externally formatted text (ex: If exam was "RTN","RAUTL2",43,0) ;done with contrast media Y="CONTRAST MEDIA USED" "RTN","RAUTL2",44,0) ;06/16/99 remove obsolete RAF2 "RTN","RAUTL2",45,0) ; add CPT Modifiers string "RTN","RAUTL2",46,0) ; output Y = procedure modifiers string "RTN","RAUTL2",47,0) ; Y(1)= CPT modifiers string, external "RTN","RAUTL2",48,0) ; Y(2)= CPT modifiers string, internal "RTN","RAUTL2",49,0) MODS ;get procedure modifiers "RTN","RAUTL2",50,0) S (Y,Y(1),Y(2))="" Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S X=^(0) "RTN","RAUTL2",51,0) F I=0:0 S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I)) Q:I'>0 I $D(^RAMIS(71.2,+^(I,0),0)) S X1=$P(^(0),"^") D MODS1 "RTN","RAUTL2",52,0) S:$P(X,"^",10)["Y" X1="CONTRAST MEDIA USED" "RTN","RAUTL2",53,0) ; "RTN","RAUTL2",54,0) MODS0 ;falls through from MODS; get CPT modifiers "RTN","RAUTL2",55,0) S:Y="" Y="None" "RTN","RAUTL2",56,0) S X=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),I=0 "RTN","RAUTL2",57,0) F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",I)) Q:I'>0 S X1=$$BASICMOD^RACPTMSC(+$G(^(I,0)),DT) I +X1>0 S Y(1)=Y(1)_$S(Y(1)="":"",1:", ")_$P(X1,"^",2),Y(2)=Y(2)_$S(Y(2)="":"",1:", ")_$P(X1,"^") "RTN","RAUTL2",58,0) S:Y(1)="" Y(1)="None" "RTN","RAUTL2",59,0) K I,X,X1 Q "RTN","RAUTL2",60,0) ; "RTN","RAUTL2",61,0) MODS1 ;builds procedure modifier string (called from MODS above) "RTN","RAUTL2",62,0) S Y=Y_$S(Y="":"",1:", ")_X1 Q "RTN","RAUTL2",63,0) ; "RTN","RAUTL2",64,0) ;called to do some order checks - takes appropriate action if: "RTN","RAUTL2",65,0) ; procedure requested needs Rad/NM physician approval (File 71, fld 11) "RTN","RAUTL2",66,0) ; there are other outstanding orders for this procedure for this pt "RTN","RAUTL2",67,0) ; user is inactivated (file 200, "I" node) "RTN","RAUTL2",68,0) ORDPRC I $D(^RAMIS(71,+X,0)),$P(^(0),"^",11)["y" D CHKUSR I 'RAMSG W !!,"Please contact appropriate Imaging Service to request this procedure! " K X,RAMSG Q "RTN","RAUTL2",69,0) S RAS3=+$P(^RAO(75.1,DA,0),"^") "RTN","RAUTL2",70,0) ORDPRC1 Q:'$D(^RAO(75.1,"AP",RAS3,X)) S RAS4=X,RASCNT=0 K RAX "RTN","RAUTL2",71,0) F RAS5=0:0 S RAS5=$O(^RAO(75.1,"AP",RAS3,RAS4,RAS5)) Q:'RAS5 F RAS6=0:0 S RAS6=$O(^RAO(75.1,"AP",RAS3,RAS4,RAS5,RAS6)) Q:'RAS6 I $D(^RAO(75.1,RAS6,0)) S RAT=+$P(^(0),"^",5) I RAT>2 S RASCNT=RASCNT+1 D:$S('$D(RAQUIT):1,1:RASCNT>1) ORDMES "RTN","RAUTL2",72,0) I $D(RAX),'$D(RAQUIT) D ORDMES1 "RTN","RAUTL2",73,0) K:$D(RAX) RAQUIT K RAMSG,RAS3,RAS4,RAS5,RAS6,RASCNT,RAT,RAX Q "RTN","RAUTL2",74,0) ; "RTN","RAUTL2",75,0) CHKUSR ; Check if valid user "RTN","RAUTL2",76,0) N RAINADT,RAC "RTN","RAUTL2",77,0) S RAINADT=+$P($G(^VA(200,+$G(DUZ),"PS")),"^",4) "RTN","RAUTL2",78,0) S RAC=$O(^VA(200,+$G(DUZ),"RAC",0)) "RTN","RAUTL2",79,0) S RAMSG=$S('($D(DUZ)#2):0,'$D(^VA(200,DUZ,0)):0,'RAC:0,'RAINADT:1,'$D(DT):0,DT'>RAINADT:1,1:0) "RTN","RAUTL2",80,0) Q "RTN","RAUTL2",81,0) ORDMES W:'$D(RAX) !!,*7,"The following requests are already on file for this procedure:",! "RTN","RAUTL2",82,0) W !?3,"A request dated " S Y=9999999.9999-RAS5 D DT^DIO2 W " is already ",$S(RAT=3:"on ",1:""),$P($P(^DD(75.1,5,0),RAT_":",2),";")," for this procedure." S RAX=1 Q "RTN","RAUTL2",83,0) ORDMES1 W !!?3,"Is it ok to continue? No// " R RAX:DTIME S:'$T!(RAX="")!(RAX["^") RAX="N" "RTN","RAUTL2",84,0) I "Nn"[$E(RAX) K X S RAPRI=0 "RTN","RAUTL2",85,0) I $D(X),"Yy"'[$E(RAX) W !!?3,"Enter 'YES' to request this procedure for this patient, or 'NO' not to.",! G ORDMES1 "RTN","RAUTL2",86,0) Q "RTN","RAUTL2",87,0) ; "RTN","RAUTL2",88,0) ;Called (from RAPSET) to determine if at least one division and at "RTN","RAUTL2",89,0) ;least one location are set up. Can't use pkg unless these are set up. "RTN","RAUTL2",90,0) CHKSP S RADV=$S($O(^RA(79,0))>0:1,1:0),RALC=$S($D(^RA(79.1,+$O(^RA(79,"AL",0)),0)):1,1:0) "RTN","RAUTL2",91,0) Q "RTN","RAUTL2",92,0) ; "RTN","RAUTL2",93,0) KILLVAR ;This call will clean up possible variables left after execution "RTN","RAUTL2",94,0) ;of the Label print fields in file 78.7 "RTN","RAUTL2",95,0) K RAY0,RAY1,RAY2,RAY3,RAGE,RACSE,RANOW,RADOB,RAEXDT,RATRAN,RARPDT,RADIAG,RAMOD,RAINST,RAEXLST,RAVST,RALCSE,RANM,RAPAGE,RAPR,RAL,RARST,RAREA,RADOC,RARAD,RASSN "RTN","RAUTL2",96,0) K RASTAFF,RASIGS,RATECH,RACTY,RASIGVES,RAVER,RASIGVS,RASIGVSB,RASIGR,RASERV,RASEX,RAS,RAII,RAFMT,RASV "RTN","RAUTL2",97,0) Q "RTN","RAUTL2",98,0) ; "RTN","RAUTL2",99,0) CONTRAST(RAZ71) ;Display the contrast media/medium associated with a Rad/Nuc "RTN","RAUTL2",100,0) ;Med Procedure. Called from: PRC1^RAUTL8 & ALLERGY^RAORD1 "RTN","RAUTL2",101,0) ;input: RAZ71=ien of the non-parent procedure in file 71 "RTN","RAUTL2",102,0) ; "RTN","RAUTL2",103,0) K RAZCM S RAZ71(0)=$G(^RAMIS(71,RAZ71,0)) "RTN","RAUTL2",104,0) S RAZCMU=$P(RAZ71(0),"^",20) ;is contrast media used? "RTN","RAUTL2",105,0) I RAZCMU'="Y" K RAZCMU Q "RTN","RAUTL2",106,0) D GETS^DIQ(71,RAZ71_",","125*","E","RAZCM") "RTN","RAUTL2",107,0) ; The RAZCM(71.0125,x,.01,"E") array will be one or more of following "RTN","RAUTL2",108,0) ; values: I:Iodinated contrast, ionic;N:Iodinated contrast, non-ionic "RTN","RAUTL2",109,0) ; L:Gadolinium, C:Cholecystogram;G:Gastrografin;B:Barium "RTN","RAUTL2",110,0) ; "RTN","RAUTL2",111,0) S:$O(RAZCM(71.0125,$C(126)),-1)=$O(RAZCM(71.0125,"")) RAZTAG="medium" "RTN","RAUTL2",112,0) S:'$D(RAZTAG)#2 RAZTAG="media" "RTN","RAUTL2",113,0) S RAPMSG(1)="************** Patient reaction to contrast "_RAZTAG_" *************" "RTN","RAUTL2",114,0) S RAPMSG(2)=$E($P(RAZ71(0),"^"),1,47)_" uses contrast "_RAZTAG_": " "RTN","RAUTL2",115,0) S RAPMSG(2,"F")="!",RAZI="",RAZSUB=$O(RAPMSG($C(32)),-1) "RTN","RAUTL2",116,0) F S RAZI=$O(RAZCM(71.0125,RAZI)) Q:RAZI="" D "RTN","RAUTL2",117,0) .S:$L($G(RAPMSG(RAZSUB)))+$L(RAZCM(71.0125,RAZI,.01,"E"))>69 RAZSUB=RAZSUB+1 "RTN","RAUTL2",118,0) .S RAPMSG(RAZSUB)=$G(RAPMSG(RAZSUB))_RAZCM(71.0125,RAZI,.01,"E")_", " "RTN","RAUTL2",119,0) .Q "RTN","RAUTL2",120,0) ; The reverse dollar order (R$O) is used to strip off the ", " string "RTN","RAUTL2",121,0) ; from the last printable subscript containing CM data. I also use the "RTN","RAUTL2",122,0) ; R$O to set my last printable array element to '*'s to box off the "RTN","RAUTL2",123,0) ; warning. "RTN","RAUTL2",124,0) S RAPMSG($O(RAPMSG($C(32)),-1))=$E(RAPMSG($O(RAPMSG($C(32)),-1)),1,$L(RAPMSG($O(RAPMSG($C(32)),-1)))-2) ;strips off the ", " "RTN","RAUTL2",125,0) S $P(RAPMSG($O(RAPMSG($C(32)),-1)+1),"*",69)="",RAPMSG(99)=" " "RTN","RAUTL2",126,0) D EN^DDIOL(.RAPMSG) "RTN","RAUTL2",127,0) K RAPMSG,RAZCM,RAZCMU,RAZI,RAZTAG,RAZSUB "RTN","RAUTL2",128,0) Q "RTN","RAUTL2",129,0) ; "RTN","RAUTL2",130,0) DELCM(DA) ;Ask the user if he/she is sure that deletion of contrast media "RTN","RAUTL2",131,0) ;is intended. If the user enter '^' exit editng the template "RTN","RAUTL2",132,0) ; input: DA=the ien of the record in file 71 "RTN","RAUTL2",133,0) ;output: RAYN=response to 'Are you sure?'; either 'Y', 'N', or '^' "RTN","RAUTL2",134,0) ;Called from the RA PROCEDURE EDIT input template (RA*5*45) "RTN","RAUTL2",135,0) N RAYN W !?3,"*** Deleting all contrast media data associated with this procedure. ***" "RTN","RAUTL2",136,0) F D Q:$L($G(RAYN)) "RTN","RAUTL2",137,0) .R !!?3,"All contrast relationships with this procedure will be deleted.",!?3,"Are you sure you want to delete? N// ",RAYN:DTIME "RTN","RAUTL2",138,0) .S:'$T!(RAYN["^") RAYN="^" Q:RAYN="^" "RTN","RAUTL2",139,0) .S:RAYN="" RAYN="N" Q:RAYN="N" "RTN","RAUTL2",140,0) .S RAYN=$$UP^XLFSTR($E(RAYN)) Q:RAYN="Y"!(RAYN="N") "RTN","RAUTL2",141,0) .I RAYN["?" W !?3,"Enter 'Y'es to delete associated contrasts, or 'N'o to preserve associated",!?3,"contrasts." K RAYN Q "RTN","RAUTL2",142,0) .K RAYN W !?3,"Please enter 'Y' for yes, or 'N' for no." "RTN","RAUTL2",143,0) .Q "RTN","RAUTL2",144,0) ;The user does not want to delete associated cm data or has '^' out of "RTN","RAUTL2",145,0) ;the option. We must reset the CONTRAST MEDIA USED (#20) field back to "RTN","RAUTL2",146,0) ;yes from no. "RTN","RAUTL2",147,0) I RAYN'="Y" D "RTN","RAUTL2",148,0) .K RAFDA S RAFDA(71,DA_",",20)="Y" D FILE^DIE("","RAFDA") "RTN","RAUTL2",149,0) .K RAFDA Q "RTN","RAUTL2",150,0) Q RAYN "RTN","RAUTL2",151,0) ; "RTN","RAUTL20") 0^61^B34736490 "RTN","RAUTL20",1,0) RAUTL20 ;HISC/SWM-Utility Routine ;6/16/97 14:27 "RTN","RAUTL20",2,0) ;;5.0;Radiology/Nuclear Medicine;**5,34,47**;Mar 16, 1998;Build 21 "RTN","RAUTL20",3,0) ; "RTN","RAUTL20",4,0) EN1 ; for displaying + and . during case lookup "RTN","RAUTL20",5,0) S RAPRTSET=0 "RTN","RAUTL20",6,0) Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI)) "RTN","RAUTL20",7,0) Q:RADFN=""!(RADTI="")!(RACNI="") "RTN","RAUTL20",8,0) ; output : RAPRTSET=1 : case is part of a combined PRINTset, & flag it "RTN","RAUTL20",9,0) ; RAMEMLOW=1 : case is lowest ien of print set AND flag it "RTN","RAUTL20",10,0) N RA1,RA2,RA3,RA4,RA5,RA6,RA7,RACN S RA1="",RA3="A",RA5=0 "RTN","RAUTL20",11,0) S RACN=+$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) "RTN","RAUTL20",12,0) S RAMEMLOW=0 "RTN","RAUTL20",13,0) S RAPRTSET=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",25)=2 "RTN","RAUTL20",14,0) Q:'RAPRTSET "RTN","RAUTL20",15,0) ; put + infront of lowest ien of case that has MEMBER OF SET = 2 "RTN","RAUTL20",16,0) F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RA1)) Q:RA1="" Q:$P($G(^(RA1,0)),U,25)=2 ; RA1 is at lowest ien with MEMBER OF SET = 2 "RTN","RAUTL20",17,0) S:RACNI=RA1 RAMEMLOW=1 "RTN","RAUTL20",18,0) S RA1="" F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RA1)) Q:RA1="" D LOOP1 "RTN","RAUTL20",19,0) I RA5 S RAPRTSET=0,RAMEMLOW=0 ;don't display if ptrs to #74 differ within set "RTN","RAUTL20",20,0) Q "RTN","RAUTL20",21,0) LOOP1 ; RA1= : for-loop var which happens to be the CASE NUMBER (70.03; .01) "RTN","RAUTL20",22,0) ; RA2= : (1) ien for 70.03 (2) also, pointer value to file #74 "RTN","RAUTL20",23,0) ; RA3= : holds earliest case with pointer value to file #74 "RTN","RAUTL20",24,0) ; RA4= : (ienof #70.03)=case number^procedure pointers^ptr #74 "RTN","RAUTL20",25,0) ; RA5=0 : all cases in set point to same non-null rarpt() or all null "RTN","RAUTL20",26,0) ; regardless of cancelled status "RTN","RAUTL20",27,0) ; RA5<>0: one or more cases in set point to different rarpt() "RTN","RAUTL20",28,0) ; RA6= : pointer to file #72 examination status "RTN","RAUTL20",29,0) ; RA7=1 : denote call of LOOP1 came from EN2 and not from EN1 "RTN","RAUTL20",30,0) S RA2=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RA1,0)) "RTN","RAUTL20",31,0) ; skip rec if it's not part of combined report "RTN","RAUTL20",32,0) Q:$P(^RADPT(RADFN,"DT",RADTI,"P",RA2,0),"^",25)'=2 "RTN","RAUTL20",33,0) N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RA2) "RTN","RAUTL20",34,0) S RACNDSP=$S((RASSAN'=""):RASSAN,1:RA1) "RTN","RAUTL20",35,0) ; "RTN","RAUTL20",36,0) I $$USESSAN^RAHLRU1() S:$G(RA7) RA4=RA2,RA4(RA4)=RACNDSP "RTN","RAUTL20",37,0) I '$$USESSAN^RAHLRU1() S:$G(RA7) RA4=RA2,RA4(RA4)=RA1 "RTN","RAUTL20",38,0) S RA2=$P(^RADPT(RADFN,"DT",RADTI,"P",RA2,0),"^",17),RA6=$P(^(0),"^",3) S:$G(RA7) RA4(RA4)=RA4(RA4)_"^"_$P(^(0),"^",2)_"^"_$P(^(0),"^",17)_"^"_$P(^(0),"^",3) "RTN","RAUTL20",39,0) ; skip if exm canc'd & exm's pc 17 is null "RTN","RAUTL20",40,0) I $P($G(^RA(72,+RA6,0)),"^",3)=0,RA2="" Q "RTN","RAUTL20",41,0) S:RA3="A" RA3=RA2 "RTN","RAUTL20",42,0) I RA5=0,RA2]"" S RA5=RA2-RA3 "RTN","RAUTL20",43,0) Q "RTN","RAUTL20",44,0) EN2(RA4) ; display all print members' procs during report editing/printg "RTN","RAUTL20",45,0) S RAPRTSET=0 "RTN","RAUTL20",46,0) Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI)) "RTN","RAUTL20",47,0) Q:RADFN=""!(RADTI="")!(RACNI="") "RTN","RAUTL20",48,0) ; output : RA4(IEN OF #70.03)=CASE NUMBER^IEN OF #71 (procedure)^ptr #74 "RTN","RAUTL20",49,0) ; ^exm stat "RTN","RAUTL20",50,0) ; RAPRTSET = 1 : case is part of a combined PRINTset "RTN","RAUTL20",51,0) N RA1,RA2,RA3,RA5,RA6,RA7 S RA1="",RA3="A",RA5=0,RA7=1 "RTN","RAUTL20",52,0) F S RA1=$O(RA4(RA1)) Q:RA1="" K RA4(RA1) ;clean up array "RTN","RAUTL20",53,0) S RAPRTSET=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),"^",25)=2 "RTN","RAUTL20",54,0) Q:'RAPRTSET "RTN","RAUTL20",55,0) F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RA1)) Q:RA1="" D LOOP1 "RTN","RAUTL20",56,0) I RA5 S RAPRTSET=0 ;don't display if ptrs to #74 differ within set "RTN","RAUTL20",57,0) Q "RTN","RAUTL20",58,0) EN3(RA4) ; for print set, AFTER record is created in rarpt() "RTN","RAUTL20",59,0) Q:'$D(RADFN)!('$D(RADTI)) "RTN","RAUTL20",60,0) Q:RADFN=""!(RADTI="") "RTN","RAUTL20",61,0) ; output :RA4(IEN OF #70.03)=CASE NUMBER (ONLY THOSE CASES FROM #74.05) "RTN","RAUTL20",62,0) N RA1,RA2,RA3,RA5 S RA1="",RA3="A" "RTN","RAUTL20",63,0) F S RA1=$O(RA4(RA1)) Q:RA1="" K RA4(RA1) ;clean up array "RTN","RAUTL20",64,0) S RA5=$S($G(RARPT):RARPT,$G(RAIEN):RAIEN,1:0) Q:RA5=0 "RTN","RAUTL20",65,0) ;Careful; Here RA1 is the accession #. Format: 081809-12345 -or- 578-081809-12345 "RTN","RAUTL20",66,0) F S RA1=$O(^RARPT(RA5,1,"B",RA1)) Q:RA1="" S RA2=$P(RA1,"-",$L(RA1,"-")),RA3=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RA2,0)),RA4(RA3)=RA2 "RTN","RAUTL20",67,0) Q "RTN","RAUTL20",68,0) XPRI ;loop thru sub-file #74.05 to set/kill prim. xref for other prt members "RTN","RAUTL20",69,0) Q:'$D(RADFNZ)!('$D(RADTIZ))!('$D(RARAD))!('$D(RAXREF))!('$D(DA)) "RTN","RAUTL20",70,0) Q:$O(^RARPT(DA,1,"B",0))="" "RTN","RAUTL20",71,0) N RA1,RA200 S RA1="" "RTN","RAUTL20",72,0) XPRI1 S RA1=$O(^RARPT(DA,1,"B",RA1)) Q:RA1="" "RTN","RAUTL20",73,0) ;S RACNIZ=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P","B",$P(RA1,"-",2),0)) "RTN","RAUTL20",74,0) S RACNIZ=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P","B",$P(RA1,"-",$L(RA1,"-")),0)) ;Set RACNIZ=last piece of RA1, not 2nd piece after P47 SSAN changes "RTN","RAUTL20",75,0) G:'$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0)) XPRI1 S RA200=+$P(^(0),"^",RARADOLD) ; use raradold to get piece number in "p" node "RTN","RAUTL20",76,0) G XPRI1:'RA200 "RTN","RAUTL20",77,0) S:$D(RASET) ^RARPT(RAXREF,RA200,DA)="" "RTN","RAUTL20",78,0) K:$D(RAKILL) ^RARPT(RAXREF,RA200,DA) "RTN","RAUTL20",79,0) G XPRI1 "RTN","RAUTL20",80,0) XSEC ;loop thru sub-file #74.05 to set/kill sec. xref for other print members "RTN","RAUTL20",81,0) Q:'$D(RADFNZ)!('$D(RADTIZ))!('$D(RASECOND))!('$D(RAXREF))!('$D(DA)) "RTN","RAUTL20",82,0) Q:$O(^RARPT(DA,1,"B",0))="" "RTN","RAUTL20",83,0) N RA1,RA2,RA200 S RA1="" "RTN","RAUTL20",84,0) XSEC1 S RA1=$O(^RARPT(DA,1,"B",RA1)) Q:RA1="" "RTN","RAUTL20",85,0) ;S RACNIZ=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P","B",$P(RA1,"-",2),0)) "RTN","RAUTL20",86,0) S RACNIZ=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P","B",$P(RA1,"-",$L(RA1,"-")),0)) "RTN","RAUTL20",87,0) G:'$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0)) XSEC1 G:'$D(^(RASECOND,0)) XSEC1 "RTN","RAUTL20",88,0) S RA2=0 "RTN","RAUTL20",89,0) XSEC2 S RA2=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,RA2)) G:'+RA2 XSEC1 S RA200=+$G(^(RA2,0)) "RTN","RAUTL20",90,0) G:'RA200 XSEC2 "RTN","RAUTL20",91,0) S:$D(RASET) ^RARPT(RAXREF,RA200,DA)="" "RTN","RAUTL20",92,0) K:$D(RAKILL) ^RARPT(RAXREF,RA200,DA) "RTN","RAUTL20",93,0) G XSEC2 "RTN","RAUTL20",94,0) FLAGMEM() ;in distr list, print + if case is part of a print set "RTN","RAUTL20",95,0) ; called from File #74's print templates "RTN","RAUTL20",96,0) N RA1 S RA1="" "RTN","RAUTL20",97,0) I '$D(D0) Q RA1 "RTN","RAUTL20",98,0) S RA1=$P($G(^RABTCH(74.4,D0,0)),U) I RA1="" Q RA1 "RTN","RAUTL20",99,0) S RA1=$O(^RARPT(RA1,1,"B",0)) S:RA1]"" RA1="+" "RTN","RAUTL20",100,0) Q RA1 "RTN","RAUTL20",101,0) DELPNT(RADFN,RADTI,RACNI) ; When an exam is cancelled & it is associated "RTN","RAUTL20",102,0) ; with data in the Nuc Med Exam Data file (70.2) ask the user if this "RTN","RAUTL20",103,0) ; pointer to 70.2 is to be deleted. Also delete the flag which "RTN","RAUTL20",104,0) ; indicates that the dosage ticket had printed for this exam. "RTN","RAUTL20",105,0) ; Called from CANCEL^RAEDCN "RTN","RAUTL20",106,0) ; Input: RADFN - Internal Entry Number (IEN) of the Patient. "RTN","RAUTL20",107,0) ; RADTI - Date/Time of the examination (inverse format) "RTN","RAUTL20",108,0) ; RACNI - IEN of the exam for this date/time "RTN","RAUTL20",109,0) ; "RTN","RAUTL20",110,0) ;- Delete entry in 'Dosage Ticket Printed?' field DD: 70.03, field: 29 - "RTN","RAUTL20",111,0) N RAFDA S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",29)="@" "RTN","RAUTL20",112,0) D FILE^DIE("","RAFDA") "RTN","RAUTL20",113,0) ;---------------------------------------------------------------------- "RTN","RAUTL20",114,0) Q:'+$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",28) ;no NucMed Xam data "RTN","RAUTL20",115,0) K RAFDA N RAYN "RTN","RAUTL20",116,0) F D Q:RAYN]"" "RTN","RAUTL20",117,0) . R !!?3,"Do you wish to delete the radiopharmaceutical data associated",!?3,"with this exam? No//",RAYN:DTIME "RTN","RAUTL20",118,0) . I RAYN["^"!('$T) S RAYN="^" Q ;don't delete pntr if '^' or timeout "RTN","RAUTL20",119,0) . S RAYN=$E(RAYN) S:RAYN="" RAYN="N" "RTN","RAUTL20",120,0) . S RAYN=$$UP^XLFSTR(RAYN) Q:RAYN="N" ;exit, don't del 70.2 pnt "RTN","RAUTL20",121,0) . I RAYN="Y" D Q ; delete the pointer to 70.2, then quit "RTN","RAUTL20",122,0) .. N RAFDA S RAFDA(70.03,RACNI_","_RADTI_","_RADFN_",",500)="@" "RTN","RAUTL20",123,0) .. D FILE^DIE("","RAFDA") "RTN","RAUTL20",124,0) .. ; NOTE: This silent FileMan call not only deletes the pointer to "RTN","RAUTL20",125,0) .. ; the entry in the Nuc Med Exam Data file (70.2), but the "RTN","RAUTL20",126,0) .. ; entry in 70.2 itself. This is because a M X-Ref exists on "RTN","RAUTL20",127,0) .. ; the field which points to file 70.2 that also deletes the "RTN","RAUTL20",128,0) .. ; entry in the Nuc Med Exam Data file. Please refer to "RTN","RAUTL20",129,0) .. ; ^DD(70.03,500,.. for more information. "RTN","RAUTL20",130,0) .. Q "RTN","RAUTL20",131,0) . W !!?3,"Enter 'Yes' to delete the radiopharmaceutical data associated with this exam.",!?3,"Enter 'No' to preserve the radiopharmaceutical data associated with this",!?3,"exam. " "RTN","RAUTL20",132,0) . W "Enter '^' to exit without deleting the radiopharmaceutical data",!?3,"associated with this exam.",$C(7) "RTN","RAUTL20",133,0) . S RAYN="" "RTN","RAUTL20",134,0) . Q "RTN","RAUTL20",135,0) Q "RTN","RAUTL3") 0^62^B11997585 "RTN","RAUTL3",1,0) RAUTL3 ;HISC/CAH,FPT,GJC AISC/SAW-Utility for Callable Entry Points ;4/1/97 10:04 "RTN","RAUTL3",2,0) ;;5.0;Radiology/Nuclear Medicine;**26,47**;Mar 16, 1998;Build 21 "RTN","RAUTL3",3,0) EN1 ;ENTRY POINT FOR AMIE CALL "RTN","RAUTL3",4,0) ;Requires four input variables "RTN","RAUTL3",5,0) ; DFN = Patient internal entry number "RTN","RAUTL3",6,0) ; Date range for report in Fileman internal format "RTN","RAUTL3",7,0) ; RABDT = Beginning Date (time optional) "RTN","RAUTL3",8,0) ; RAEDT = Ending Date (time optional) "RTN","RAUTL3",9,0) ; Exam locations (from file 44, Hospital Location) that are to be "RTN","RAUTL3",10,0) ; included in the report "RTN","RAUTL3",11,0) ; RAHLOC = A string of internal entry numbers for locations "RTN","RAUTL3",12,0) ; Each location separated by ^ and RAHLOC must begin "RTN","RAUTL3",13,0) ; and end with an ^ (e.g., RAHLOC=^3^ or RAHLOC=^56^75^) "RTN","RAUTL3",14,0) ; These are REQUESTING locations, not imaging locations "RTN","RAUTL3",15,0) ; "RTN","RAUTL3",16,0) I '$D(DFN)!('$D(RAHLOC))!('$D(RABDT))!('$D(RAEDT)) W !!,"Required variables are not defined. Unable to continue.",*7 Q "RTN","RAUTL3",17,0) S RAMIE=1 F RAPTR=RABDT-.0000001:0 S RAPTR=$O(^RADPT(DFN,"DT","B",RAPTR)) Q:RAPTR'>0!(RAPTR>RAEDT) S RAPTR1=$O(^(RAPTR,0)) I RAPTR1 F RAPTR2=0:0 S RAPTR2=$O(^RADPT(DFN,"DT",RAPTR1,"P",RAPTR2)) Q:RAPTR2'>0 I $D(^(RAPTR2,0)) S RAEX=^(0) D CHK "RTN","RAUTL3",18,0) K RACNI,RAEX,RAII,RAK,RAMDIV,RAMDV,RAMLC,RAMIE,RANUM,RAPT1,RAPTR,RAPTR1,RAPTR2,RASSN,RAST Q "RTN","RAUTL3",19,0) CHK I $P(RAEX,U,17),RAHLOC[(U_$P(RAEX,U,22)_U) S RAST=$S($D(^RARPT($P(RAEX,"^",17),0)):^(0),1:"") I "VR"[$P(RAST,"^",5) S RARPT=$P(RAEX,"^",17),RAPT1=1 D ^RARTR F RAK=0:0 S RAK=$O(^RA(78.7,RAK)) Q:RAK'>0 I $D(^(RAK,0)) K @$P(^(0),"^",5) "RTN","RAUTL3",20,0) Q "RTN","RAUTL3",21,0) SIGNON ;Check the # of reports to either pre-verify of verify. "RTN","RAUTL3",22,0) Q:'$D(DUZ)#2 N RA74,X0,X1,Y1 S (X0,X1,Y1)=0 "RTN","RAUTL3",23,0) ; first, tabulate # (Y1) of reports to pre-verify (if any) "RTN","RAUTL3",24,0) F S X0=$O(^RARPT("ARES",DUZ,X0)) Q:X0'>0 D "RTN","RAUTL3",25,0) . S RA74=$G(^RARPT(X0,0)) "RTN","RAUTL3",26,0) . Q:$$STUB^RAEDCN1(X0) ; skip stub report 031501 "RTN","RAUTL3",27,0) . Q:$P(RA74,"^",5)="V" ; skip if already verified "RTN","RAUTL3",28,0) . S:$P(RA74,"^",12)']"" Y1=Y1+1 "RTN","RAUTL3",29,0) . Q "RTN","RAUTL3",30,0) S:Y1 X0="!*** You have "_Y1_" imaging report"_$S(Y1>1:"s",1:"")_" to pre-verify. ***" "RTN","RAUTL3",31,0) D:Y1 SET^XUS1A(X0) "RTN","RAUTL3",32,0) ; next tabulate # (X1) of reports to verify (if any) "RTN","RAUTL3",33,0) S X0=0 F S X0=$O(^RARPT("ASTF",DUZ,X0)) Q:X0'>0 D "RTN","RAUTL3",34,0) . S RA74=$G(^RARPT(X0,0)) "RTN","RAUTL3",35,0) . Q:$$STUB^RAEDCN1(X0) ; skip stub report 031501 "RTN","RAUTL3",36,0) . Q:$P(RA74,"^",5)="V" ; skip if already verified "RTN","RAUTL3",37,0) . S X1=X1+1 "RTN","RAUTL3",38,0) Q:X1'>0 "RTN","RAUTL3",39,0) S X0="!*** You have "_X1_" imaging report"_$S(X1>1:"s",1:"")_" to verify. ***" "RTN","RAUTL3",40,0) D SET^XUS1A(X0) "RTN","RAUTL3",41,0) Q "RTN","RAUTL3",42,0) UPDT(RANODE) ; Delete blank lines for Rad/Nuc Med Word Processing fields. "RTN","RAUTL3",43,0) ; These 'blank' consist of nothing more than spaces. "RTN","RAUTL3",44,0) ; 'RANODE' is the data node to be examined: i.e, for Clinical History "RTN","RAUTL3",45,0) ; in Rad/Nuc Med Orders (75.1) RANODE="^RAO(75.1,"_DA_",H," "RTN","RAUTL3",46,0) ; -or in Rad/Nuc Med Reports (74) RANODE="^RARPT(DA_",R," "RTN","RAUTL3",47,0) ; "RTN","RAUTL3",48,0) N RA0,RACNT,RAI,RATCNT,RAXIT,RAY "RTN","RAUTL3",49,0) S (RACNT,RATCNT,RAXIT)=0 S RAI=999999999 "RTN","RAUTL3",50,0) S RAY=$G(@(RANODE_"0)")),RAY(4)=+$P(RAY,"^",4) Q:'RAY(4) "RTN","RAUTL3",51,0) F S RAI=$O(@(RANODE_RAI_")"),-1) Q:RAI'>0 D Q:RAXIT "RTN","RAUTL3",52,0) . S RA0=$G(@(RANODE_RAI_",0)")) "RTN","RAUTL3",53,0) . I RA0?1.999" " D "RTN","RAUTL3",54,0) .. K @(RANODE_RAI_",0)") S RACNT=RACNT+1 "RTN","RAUTL3",55,0) . E S RAXIT=1 "RTN","RAUTL3",56,0) . Q "RTN","RAUTL3",57,0) I RACNT D "RTN","RAUTL3",58,0) . S RATCNT=RAY(4)-RACNT "RTN","RAUTL3",59,0) . S @(RANODE_"0)")="^^"_RATCNT_"^"_RATCNT_"^"_$S($D(DT)#2:DT,1:$$DT^XLFDT()) "RTN","RAUTL3",60,0) . Q "RTN","RAUTL3",61,0) Q "RTN","RAUTL3",62,0) ; "RTN","RAUTL3",63,0) GETLCN() ;Build & return a long case number (accession) for a live case. "RTN","RAUTL3",64,0) ;Called from File: 78.7; field: 100; Record: LONG CASE NUMBER (p47) "RTN","RAUTL3",65,0) ; "RTN","RAUTL3",66,0) ;input: RADFN -DFN of the patient "RTN","RAUTL3",67,0) ; RADTI -inverse date/time of the exam "RTN","RAUTL3",68,0) ; RACNI -the IEN of the case record (70.03) "RTN","RAUTL3",69,0) ; RAMDIV-Division (File: 79); derived from sign-on location "RTN","RAUTL3",70,0) ; Note: all have a global scope; all are expected to exist "RTN","RAUTL3",71,0) ; "RTN","RAUTL3",72,0) ; RAY2 -zero node of the REGISTERED EXAMS subfile (70.02) "RTN","RAUTL3",73,0) ; RAY3 -zero node of the EXAMINATIONS subfile (70.03) "RTN","RAUTL3",74,0) ; "RTN","RAUTL3",75,0) ; RAY2 & RAY3 may exist depending on the option executed. If RAY2 & RAY3 do not exist "RTN","RAUTL3",76,0) ; use RASAV2 & RASAV3 defined when RA REG is executed. "RTN","RAUTL3",77,0) ; "RTN","RAUTL3",78,0) ; Site Specific Accession Number (SSAN) "RTN","RAUTL3",79,0) ; "RTN","RAUTL3",80,0) N RAX S RAX="" "RTN","RAUTL3",81,0) I '$D(RAY2)#2 N RAY2 S RAY2=$G(RASAV2) "RTN","RAUTL3",82,0) I '$D(RAY3)#2 N RAY3 S RAY3=$G(RASAV3) "RTN","RAUTL3",83,0) I $$USESSAN^RAHLRU1() D ;if true get SSAN "RTN","RAUTL3",84,0) .;format: 578-081194-12345 "RTN","RAUTL3",85,0) .S RAX=$$ACCNUM^RAAPI(RADFN,RADTI,RACNI) Q "RTN","RAUTL3",86,0) ; "RTN","RAUTL3",87,0) E D ;else get original accession "RTN","RAUTL3",88,0) .;format: 081194-12345 "RTN","RAUTL3",89,0) .S RAX=$TR($$FMTE^XLFDT(($P(RAY2,"^")\1),"2F")," /","0")_"-"_+RAY3 Q "RTN","RAUTL3",90,0) ; "RTN","RAUTL3",91,0) Q RAX "RTN","RAUTL3",92,0) ; "UP",70,70.02,-1) 70^DT "UP",70,70.02,0) 70.02 "UP",70,70.03,-2) 70^DT "UP",70,70.03,-1) 70.02^P "UP",70,70.03,0) 70.03 "UP",74,74.05,-1) 74^1 "UP",74,74.05,0) 74.05 "VER") 8.0^22.0 "^DD",70,70,2,0) REGISTERED EXAMS^70.02DA^^DT;0 "^DD",70,70,2,.1) REGISTERED EXAMS SUB-FIELD "^DD",70,70,2,10) "^DD",70,70,2,21,0) ^.001^2^2^3101021^^^^ "^DD",70,70,2,21,1,0) This is a multiple field containing information about the patient's "^DD",70,70,2,21,2,0) registered Radiology/Nuclear Medicine exams. "^DD",70,70,2,"DT") 3090414 "^DD",70,70.02,0) REGISTERED EXAMS SUB-FIELD^NL^50^6 "^DD",70,70.02,0,"NM","REGISTERED EXAMS") "^DD",70,70.02,.01,0) EXAM DATE^DXI^^0;1^X ^DD(70.02,.01,9.2) S %DT="RET",%DT(0)=-$$FMADD^XLFDT($$NOW^XLFDT,0,$S($D(RAHRS):RAHRS,1:168),0,0) D ^%DT K %DT S X=Y K:Y<0 X S:$D(X) DINUM=9999999.9999-X "^DD",70,70.02,.01,.1) DATE AND TIME OF THIS EXAM. "^DD",70,70.02,.01,1,0) ^.1 "^DD",70,70.02,.01,1,1,0) 70.02^B "^DD",70,70.02,.01,1,1,1) S ^RADPT(DA(1),"DT","B",$E(X,1,30),DA)="" "^DD",70,70.02,.01,1,1,2) K ^RADPT(DA(1),"DT","B",$E(X,1,30),DA) "^DD",70,70.02,.01,1,1,"%D",0) ^^1^1^2940517^ "^DD",70,70.02,.01,1,1,"%D",1,0) Regular cross reference on the '.01' field. "^DD",70,70.02,.01,1,3,0) 70^AR "^DD",70,70.02,.01,1,3,1) S ^RADPT("AR",$E(X,1,30),DA(1),DA)="" "^DD",70,70.02,.01,1,3,2) K ^RADPT("AR",$E(X,1,30),DA(1),DA) "^DD",70,70.02,.01,1,3,"%D",0) ^^2^2^2940517^ "^DD",70,70.02,.01,1,3,"%D",1,0) This cross reference is the exam date and DFN. It is used on "^DD",70,70.02,.01,1,3,"%D",2,0) most work load reports including AMIS. "^DD",70,70.02,.01,3) Enter the date of the examination. "^DD",70,70.02,.01,9.2) I $D(RAMDIV) N RAHRS S RAHRS=+$P($G(^RA(79,+RAMDIV,.1)),"^",24) "^DD",70,70.02,.01,10) RECEPTIONIST "^DD",70,70.02,.01,21,0) ^.001^3^3^3090422^^ "^DD",70,70.02,.01,21,1,0) This field contains the date and also the time of this Imaging exam. The "^DD",70,70.02,.01,21,2,0) system stores the exam dates in reverse chronological order to produce "^DD",70,70.02,.01,21,3,0) reports efficiently. "^DD",70,70.02,.01,"DT") 3090423 "^DD",70,70.03,31,0) SITE ACCESSION NUMBER^RFI^^0;31^K:$L(X)>16!($L(X)<12)!'(X?3N1"-"6N1"-"1.5N) X "^DD",70,70.03,31,3) SITE ACCESSION NUMBER is generated by the application. It consists of the site number, date/time and sequential case number separated by dashes. The total length is 12-16 characters. "^DD",70,70.03,31,21,0) ^.001^11^11^3090423^^^ "^DD",70,70.03,31,21,1,0) The SITE ACCESSION NUMBER is generated by the VistA Radiology/Nuclear "^DD",70,70.03,31,21,2,0) Medicine application. "^DD",70,70.03,31,21,3,0) "^DD",70,70.03,31,21,4,0) SITE ACCESSION NUMBER is a Free Text data type between 12-16 characters in "^DD",70,70.03,31,21,5,0) length. It is created by appending a three-character site identifier to "^DD",70,70.03,31,21,6,0) the accession number. This field allows other applications to "look up" "^DD",70,70.03,31,21,7,0) an exam record based on a site specific accession number. "^DD",70,70.03,31,21,8,0) "^DD",70,70.03,31,21,9,0) Example: site id-mmddyy-case # "^DD",70,70.03,31,21,10,0) "^DD",70,70.03,31,21,11,0) In the example the dash "-" is the delimiter. "^DD",70,70.03,31,23,0) ^.001^16^16^3090423^^ "^DD",70,70.03,31,23,1,0) The site specific portion of the accession number is determined by the "^DD",70,70.03,31,23,2,0) following algorithm: $E($P($$NS^XUAF4($$KSP^XUPARAM("INST")),U,2),1,3) "^DD",70,70.03,31,23,3,0) where: "^DD",70,70.03,31,23,4,0) "^DD",70,70.03,31,23,5,0) $$KSP^XUPARAM("INST")=DEFAULT INSTITUTION file: 8989.3; field: 217 "^DD",70,70.03,31,23,6,0) data returned: pointer to the INSTITUTION (#4) file record "^DD",70,70.03,31,23,7,0) "^DD",70,70.03,31,23,8,0) $$NS^XUAF4(Y)=Input : 'Y' is the value returned from "^DD",70,70.03,31,23,9,0) $$KSP^XUPARAM("INST"). Returns: A string value containing the name (1st "^DD",70,70.03,31,23,10,0) piece) & station # (2nd piece) of the institution. "^DD",70,70.03,31,23,11,0) "^DD",70,70.03,31,23,12,0) The SITE ACCESSION NUMBER field has set the 'write' node to the caret to "^DD",70,70.03,31,23,13,0) prohibit a user from jumping to this field within an input template with "^DD",70,70.03,31,23,14,0) the intention of editing the data. "^DD",70,70.03,31,23,15,0) "^DD",70,70.03,31,23,16,0) Released as a component within RA*5.0*47. "^DD",70,70.03,31,"DT") 3090423 "^DD",70,70.03,81,0) STUDY INSTANCE UID^F^^SIUID;E1,240^K:$L(X)>240!($L(X)<3) X "^DD",70,70.03,81,3) Answer must be 3-240 characters in length. "^DD",70,70.03,81,21,0) ^.001^11^11^3101021^^ "^DD",70,70.03,81,21,1,0) This field will store the Study Instance UID. "^DD",70,70.03,81,21,2,0) "^DD",70,70.03,81,21,3,0) The Study Instance UID is a unique key that associates the images to a "^DD",70,70.03,81,21,4,0) particular study, and thus is required in messages sent to the PACS. "^DD",70,70.03,81,21,5,0) "^DD",70,70.03,81,21,6,0) An Imaging API will be used to generate the Study Instance UID and the "^DD",70,70.03,81,21,7,0) Study Instance UID will be sent in specific v2.4 HL7 event messages "^DD",70,70.03,81,21,8,0) (when an order is registered, an exam cancelled, or when an exam reaches "^DD",70,70.03,81,21,9,0) the Examined status). This will allow Vista Radiology to send event "^DD",70,70.03,81,21,10,0) transactions to a commercial PACS directly, bypassing the "^DD",70,70.03,81,21,11,0) Vista DICOM Text Gateway. "^DD",70,70.03,81,"DT") 3101028 "^DD",74,74,.01,0) DAY-CASE#^RF^^0;1^K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>16!($L(X)<8)!'(X?6N1"-"1N.N!(X?3N1"-"6N1"-"1N.N)) X "^DD",74,74,.01,.1) DATE AND CASE NUMBER OF EXAM "^DD",74,74,.01,1,0) ^.1 "^DD",74,74,.01,1,1,0) 74^B "^DD",74,74,.01,1,1,1) S ^RARPT("B",$E(X,1,30),DA)="" "^DD",74,74,.01,1,1,2) K ^RARPT("B",$E(X,1,30),DA) "^DD",74,74,.01,1,1,"%D",0) ^^1^1^2940518^ "^DD",74,74,.01,1,1,"%D",1,0) Regular 'B' cross reference assigned by FileMan. "^DD",74,74,.01,1,2,0) 74^ABLTN^MUMPS "^DD",74,74,.01,1,2,1) Q "^DD",74,74,.01,1,2,2) D:+$G(RAPRG74) ^RABUL3 Q "^DD",74,74,.01,1,2,3) Do not delete. "^DD",74,74,.01,1,2,"%D",0) ^^2^2^2941129^ "^DD",74,74,.01,1,2,"%D",1,0) This bulletin will be delivered to all the members of the RAD/NUC MED "^DD",74,74,.01,1,2,"%D",2,0) REPORT DELETION mail group when a report is deleted. "^DD",74,74,.01,1,2,"DT") 2940204 "^DD",74,74,.01,3) Answer must be 8-16 characters in length. "^DD",74,74,.01,10) SYSTEM GENERATED "^DD",74,74,.01,21,0) ^.001^7^7^3090417^^^^ "^DD",74,74,.01,21,1,0) This field contains the date and case number of the imaging exam "^DD",74,74,.01,21,2,0) associated with this report. The system fills in this field with "^DD",74,74,.01,21,3,0) information obtained from the 'RAD/NUC MED PATIENT' file (#70) according "^DD",74,74,.01,21,4,0) to the case number selected by the transcriptionist. "^DD",74,74,.01,21,5,0) "^DD",74,74,.01,21,6,0) If the Site Specific Accession Number is in use then the 3-digit Site ID "^DD",74,74,.01,21,7,0) is appended to the beginning of the field. "^DD",74,74,.01,23,0) ^^12^12^3090417^ "^DD",74,74,.01,23,1,0) Patch RA*5*56 replaces the actual deletion of a report with a change of "^DD",74,74,.01,23,2,0) the report status to 'X'. Thus the Radiology application does not "^DD",74,74,.01,23,3,0) invoke routine RABUL3 via the kill logic, instead it invokes routine "^DD",74,74,.01,23,4,0) RABUL3 via a new routine, RARTE7. "^DD",74,74,.01,23,5,0) "^DD",74,74,.01,23,6,0) Patch RA*5*47 modifies the input transform of the .01 field by expanding "^DD",74,74,.01,23,7,0) the field to allow up to 16 characters and by modifying the pattern match "^DD",74,74,.01,23,8,0) to allow the Site ID and a "-" at the beginning of the field. "^DD",74,74,.01,23,9,0) "^DD",74,74,.01,23,10,0) EXAMPLES: "^DD",74,74,.01,23,11,0) "Old" Day-Case #: 030309-3025 "^DD",74,74,.01,23,12,0) "New" Day-Case #: 141-030309-3025 <-- Site ID appended to the beginning "^DD",74,74,.01,"DT") 3090326 "^DD",74,74,4.5,0) OTHER CASE#^74.05^^1;0 "^DD",74,74.05,0) OTHER CASE# SUB-FIELD^^.01^1 "^DD",74,74.05,0,"NM","OTHER CASE#") "^DD",74,74.05,.01,0) OTHER CASE#^F^^0;1^K:$L(X)>16!($L(X)<8)!'(X?6N1"-"1N.N!(X?3N1"-"6N1"-"1N.N)) X "^DD",74,74.05,.01,1,0) ^.1 "^DD",74,74.05,.01,1,1,0) 74.05^B "^DD",74,74.05,.01,1,1,1) S ^RARPT(DA(1),1,"B",$E(X,1,30),DA)="" "^DD",74,74.05,.01,1,1,2) K ^RARPT(DA(1),1,"B",$E(X,1,30),DA) "^DD",74,74.05,.01,1,2,0) 74^SET "^DD",74,74.05,.01,1,2,1) S ^RARPT("SET",$E(X,1,30),DA(1),DA)="" "^DD",74,74.05,.01,1,2,2) K ^RARPT("SET",$E(X,1,30),DA(1),DA) "^DD",74,74.05,.01,1,2,"DT") 2960208 "^DD",74,74.05,.01,3) Answer must be 8-16 characters in length. "^DD",74,74.05,.01,21,0) ^.001^6^6^3090417^^ "^DD",74,74.05,.01,21,1,0) This field contains the date and case number of "^DD",74,74.05,.01,21,2,0) any other imaging exams associated with this report. "^DD",74,74.05,.01,21,3,0) "^DD",74,74.05,.01,21,4,0) If the Site Specific Accession Number is in use "^DD",74,74.05,.01,21,5,0) then the 3-digit Site ID is appended to the beginning "^DD",74,74.05,.01,21,6,0) of this field. "^DD",74,74.05,.01,23,0) ^^7^7^3090417^ "^DD",74,74.05,.01,23,1,0) Patch RA*5*47 modifies the input transform of the .01 field by expanding "^DD",74,74.05,.01,23,2,0) the field to allow up to 16 characters and by modifying the pattern match "^DD",74,74.05,.01,23,3,0) to allow the Site ID and a "-" at the beginning of the field. "^DD",74,74.05,.01,23,4,0) "^DD",74,74.05,.01,23,5,0) EXAMPLES: "^DD",74,74.05,.01,23,6,0) "Old" Day-Case #: 030309-3025 "^DD",74,74.05,.01,23,7,0) "New" Day-Case #: 141-030309-3025 <-- Site ID appended to the beginning. "^DD",74,74.05,.01,"DT") 3090326 "^DD",79,79,.131,0) USE SITE ACCESSION NUMBER?^S^Y:YES;N:NO;^.1;31^Q "^DD",79,79,.131,3) Set this field to YES only when all devices are able to handle Site Specific Accession Numbers. "^DD",79,79,.131,21,0) ^^6^6^3090318^ "^DD",79,79,.131,21,1,0) This parameter will function as a switch to turn on the use of the "^DD",79,79,.131,21,2,0) Site Specific Accession Number. Until this field is set to YES the "^DD",79,79,.131,21,3,0) system will NOT use the Site Specific Accession Number during "^DD",79,79,.131,21,4,0) registration of a new case. Only when all devices are able to handle "^DD",79,79,.131,21,5,0) the Site Specific Accession Number should this field be set to YES, "^DD",79,79,.131,21,6,0) at which point the system will use the Site Specific Accession Number. "^DD",79,79,.131,"DT") 3080916 **END** **END**