- RAORD5 ;HISC/CAH,FPT,GJC AISC/RMO-Print A Request ; Mar 16, 2023@06:47:25
- ;;5.0;Radiology/Nuclear Medicine;**8,10,15,31,45,75,123,132,149,200**;Mar 16, 1998;Build 2
- ; Input: RADFN= Internal Number to Rad/Nuc Med Patient File #70
- ; RAOIFN= Internal Number to Rad/Nuc Med Orders File #75.1
- ; RAX= Null (Used to check for an '^')
- ; RAPGE= 0 (Used as a page counter)
- ;
- ; Supported IA #1120 reference to EN6^GMRVUTL 5-P123,5-132
- ; Reference to ^SC(D0,99) is supported by ICR #4782
- ;
- ; 1-p75 10/12/2006 GJC RA*5*75 Remedy 162508 Modify Patient AGE calc
- ; 2-p75 10/12/2006 GJC RA*5*75 set REASON FOR STUDY to a local variable
- ; 5-P123 6/23/2015 MJT RA*5*123 NSR 20140507 print weight & date taken in Radiology requests
- ; 5-P132 11/1/2017 RTW RA*5*123 NSR 20160706 print height & date taken in Radiology requests
- ; 1-p200 3/01/2023 KLM RA*5*200 NSR 20220815 add patient's preferred name to patient name variable
- ;
- S:$D(ZTQUEUED) ZTREQ="@"
- N DFN,GMRVSTR,RAHDX,RAPROC,RAPREFNM
- G Q:'$D(^DPT(RADFN,0)) S RADPT0=^(0) G Q:'$D(^RAO(75.1,RAOIFN,0)) S RAORD0=^(0)
- S RAPREFNM=$$GET1^DIQ(2,RADFN,.2405) ;1-p200 get patient preferred name.
- S RAPROC=$P(RAORD0,"^",2)
- K ^UTILITY($J,"W"),^(1) S RAOSTSYM="dc^c^h^^p^^^s",$P(RALNE,"-",79)="",$P(RALNE1,"=",79)="",DIWL=5,DIWR=75,DIWF="WC75"
- S RA("NME")=$P(RADPT0,"^") I RAPREFNM]"" S RA("NME")=RA("NME")_" ("_RAPREFNM_")" ;1-p200 - Append preferred name in parenthesis: PT NAME (PRF NAME)
- S RA("SEX")=$P(RADPT0,"^",2),RA("DOB")=$P(RADPT0,"^",3),RASSN=$$SSN^RAUTL
- S RA("AGE")=($$FMDIFF^XLFDT($P(RAORD0,U,16),RA("DOB")))\365.25 ;1-p75
- S RA("STY_REA")=$P($G(^RAO(75.1,RAOIFN,.1)),U) ;2-p75
- S RA("PRC NODE")=$G(^RAMIS(71,+RAPROC,0))
- S RA("PRC")=$E($P(RA("PRC NODE"),U),1,36)
- S RA("PRC")=$S(RA("PRC")]"":RA("PRC"),1:"UNKNOWN")
- S RA("PRCTY")=$P(RA("PRC NODE"),U,6)
- S RA("PRCTY")=$$GET1^DIQ(71,RAPROC_",",6) ;$$XTERNAL^RAUTL5(RA("PRCTY"),$P($G(^DD(71,6,0)),U,2))
- S RA("PRCTY")=$E(RA("PRCTY"))_$$LOW^XLFSTR($E(RA("PRCTY"),2,99))
- S RA("CPT")=+$P(RA("PRC NODE"),U,9)
- S RA("CPT")=$P($$NAMCODE^RACPTMSC(RA("CPT"),DT),U)
- S RA("PRCIT")=+$P(RA("PRC NODE"),U,12)
- S RA("PRCIT")=$P($G(^RA(79.2,RA("PRCIT"),0)),U,3)
- S RA("CNCAT")="("_RA("PRCIT")_" "_RA("PRCTY")_" "_RA("CPT")_")"
- S RA("PRC INFO")="",$E(RA("PRC INFO"),1,36)=RA("PRC")
- S $E(RA("PRC INFO"),38,60)=RA("CNCAT") K RA("CNCAT")
- S RA("PRC MSG")=$S(+$O(^RAMIS(71,+$P(RAORD0,"^",2),3,0))>0:1,1:0)
- S RA("OUG")=$$GET1^DIQ(75.1,RAOIFN_",",6) ;$P($P(^DD(75.1,6,0),$P(RAORD0,"^",6)_":",2),";")
- K RA("MOD") F I=0:0 S I=$O(^RAO(75.1,RAOIFN,"M","B",I)) Q:'I I $D(^RAMIS(71.2,+I,0)) S RA("MOD")=$S('$D(RA("MOD")):$P(^(0),"^"),1:RA("MOD")_", "_$P(^(0),"^")) S:$P($G(^(0)),U,2)="p" RA("PORTABLE")=""
- S RA("OST")=$$GET1^DIQ(75.1,RAOIFN_",",5)_$S($P(RAOSTSYM,"^",$P(RAORD0,"^",5))="":"",1:" ("_$P(RAOSTSYM,"^",$P(RAORD0,"^",5))_")")
- S RA("PHY")=$S($D(^VA(200,+$P(RAORD0,"^",14),0)):$P(^(0),"^"),1:"UNKNOWN")
- ; Requesting Physician Phone info
- D:RA("PHY")'="UNKNOWN" PHONE("R",+$P(RAORD0,"^",14))
- ; Get current primary and attending physicians
- S DFN=RADFN,VA200=1 D IN5^VADPT K VA200 S:'$D(VAIP(18)) VAIP(18)=""
- ; *** NSR 20140507 Start Mod to print weight & date taken in Radiology requests 5-P123 ***
- S DFN=RADFN,GMRVSTR="WT"
- D EN6^GMRVUTL
- S RA("WT")=$P(X,U,8),Y=$P(X,U) D DD^%DT S RA("WTDT")=Y
- ;RTW BEGIN RA*5.0*132 ADD HEIGHT
- S DFN=RADFN,GMRVSTR="HT"
- D EN6^GMRVUTL S RAHDX=$G(X)
- S Y=$P(RAHDX,U,1) I Y>0 D DD^%DT S RA("HTDT")=Y
- S RA("HT")=$P(RAHDX,U,8)
- ;RTW END RA*5.0*132 ADD HEIGHT
- ; actual print code located in RAORD6
- ; *** NSR 20140507 End Mod to print weight & date taken in Radiology requests ***
- I '+$G(VAIP(7)) D
- . ; If the Primary Physician is not found (based on inpatient episode)
- . ; find the current Primary Care Practitioner (See patch SD*5.3*30)
- . ; VAIP(7) is null at this point. VAIP(7) will exit this DO block
- . ; set to the Primary Care Practitioner or null.
- . N X S X="SDUTL3" X ^%ZOSF("TEST")
- . S:$T VAIP(7)=$$OUTPTPR^SDUTL3(RADFN)
- . Q
- ; Get Current Primary and Attending Physician Phone info
- S RA("ATTEN")=$S($P(VAIP(18),"^",2)]"":$P(VAIP(18),"^",2),1:"UNKNOWN")
- D:RA("ATTEN")'="UNKNOWN" PHONE("A",+$G(VAIP(18)))
- S RA("PRIM")=$S($P(VAIP(7),"^",2)]"":$P(VAIP(7),"^",2),1:"UNKNOWN")
- D:RA("PRIM")'="UNKNOWN" PHONE("P",+$G(VAIP(7)))
- ; Requesting location, room-bed
- S RA("HLC")=$S($D(^SC(+$P(RAORD0,"^",22),0)):$P(^(0),"^"),1:"UNKNOWN"),RA("HPH")=$S($D(^SC(+$P(RAORD0,"^",22),99)):$P(^(99),"^"),1:"") I VAIP(1) S RA("ROOM-BED")=$S(+VAIP(6):$P(VAIP(6),"^",2),1:"")
- ; Get primary and attending phys as of order date and their phone, etc.
- K RA("ODT") S Y=$P(RAORD0,"^",16) I Y S:$P(Y,".",2) Y=$P(Y,".")_"."_$$NOSECNDS^RAORD3($P(Y,".",2)) S RA("ODT")=$$FMTE^XLFDT(Y,"1P")
- K VAIP S DFN=RADFN,VAIP("D")=+$P(RAORD0,"^",16),VA200=1 D:VAIP("D") IN5^VADPT K VA200
- S RA("OATTEN")=$S($P($G(VAIP(18)),"^",2)]"":$P(VAIP(18),"^",2),1:"UNKNOWN")
- D:RA("OATTEN")'="UNKNOWN" PHONE("OA",+$G(VAIP(18)))
- S RA("OPRIM")=$S($P($G(VAIP(7)),"^",2)]"":$P(VAIP(7),"^",2),1:"UNKNOWN")
- D:RA("OPRIM")'="UNKNOWN" PHONE("OP",+$G(VAIP(7)))
- ; Get other order info (orderer, transport mode, etc.)
- ;S RA("USR")=$S($D(^VA(200,+$P(RAORD0,"^",15),0)):$P(^(0),"^"),1:"UNKNOWN"),RA("TRAN")=$S($P(RAORD0,"^",19)']"":"UNKNOWN",1:$P($P(^DD(75.1,19,0),$P(RAORD0,"^",19)_":",2),";")) S:$P(RAORD0,"^",19)="p" RA("PORTABLE")=""
- S RA("USR")=$S($D(^VA(200,+$P(RAORD0,"^",15),0)):$P(^(0),"^"),1:"UNKNOWN"),RA("TRAN")=$S($P(RAORD0,"^",19)="":"UNKNOWN",1:$$GET1^DIQ(75.1,RAOIFN_",",19)) S:$P(RAORD0,"^",19)="p" RA("PORTABLE")=""
- K RA("ST"),^TMP($J,"RA DIFF PRC")
- ;determine if ordered procedure has CM assoc.; return null if none
- S RACMFLG("O")=$$CMEDIA^RAO7UTL(+$P(RAORD0,U,2),$P(RA("PRC NODE"),U,6))
- ; If appropriate, determine exam status and descendant exams
- I $D(^RADPT("AO",RAOIFN,RADFN)) D DPRC^RAORD2(RAOIFN,RADFN)
- S RADIV(0)=$G(^SC(+$P(RAORD0,"^",22),0))
- S RADIV=+$$SITE^VASITE(DT,+$P(RADIV(0),"^",15)) S:RADIV<0 RADIV=0
- S RADIV=$S($D(^RA(79,RADIV,0)):RADIV,1:$O(^RA(79,0)))
- S RADIVPAR=$S($D(^RA(79,+RADIV,.1)):^(.1),1:"")
- K RA("RDT") S Y=$P(RAORD0,"^",21) I Y S:$P(Y,".",2) Y=$P(Y,".")_"."_$$NOSECNDS^RAORD3($P(Y,".",2)) S RA("RDT")=$$FMTE^XLFDT(Y,"1P")
- K RA("PDT") S Y=$P(RAORD0,"^",12) I Y S:$P(Y,".",2) Y=$P(Y,".")_"."_$$NOSECNDS^RAORD3($P(Y,".",2)) S RA("PDT")=$$FMTE^XLFDT(Y,"1P")
- K RA("VDT") S Y=$P(RAORD0,"^",17) I Y S:$P(Y,".",2) Y=$P(Y,".")_"."_$$NOSECNDS^RAORD3($P(Y,".",2)) S RA("VDT")=$$FMTE^XLFDT(Y,"1P")
- K RA("SDT") S Y=$P(RAORD0,"^",23) I Y S:$P(Y,".",2) Y=$P(Y,".")_"."_$$NOSECNDS^RAORD3($P(Y,".",2)) S RA("SDT")=$$FMTE^XLFDT(Y,"1P")
- S RA("ILC")=$S('$P(RAORD0,"^",20):"UNKNOWN",'$D(^RA(79.1,+$P(RAORD0,"^",20),0)):"UNKNOWN",$D(^SC(+^(0),0)):$P(^(0),"^"),1:"UNKNOWN")
- D ^RAORD6
- ;
- Q K DIWF,DIWL,DIWR,I,RA,RABARC,RABARC0,RABARC1,RADIV,RADIVPAR,RADPT0,RALNE,RALNE1,RAORD0,RAOSTSYM,RATAB,RAV,RASSN,RAXX,VA200,VAERR,VAIP,X,X1,X2,X3,Y,ZZ
- K RACMFLG,RALOC,^TMP($J,"RA DIFF PRC")
- Q
- PHONE(X,Y) ; Setup phone information for Resident Physicians, Attending
- ; Physicians, and Primary Physicians.
- ; 'X' -> $S('A':'Attending','OA':'Old Attending','OP':'Old Primary',
- ; ,'P':'Primary','R':'Resident')
- ; 'Y' -> ien for file 200
- ; RA(X_"PHON")=Phone node <> RA(X_"OPHO")=Office phone
- ; RA(X_"VPGR")=Voice pager <> RA(X_"DPGR")=Digital pager
- ; RA(X_"PHOINFO")=office phone/voice pager/digital pager
- S RA(X_"PHON")=$G(^VA(200,+Y,.13))
- S RA(X_"OPHO")=$P(RA(X_"PHON"),U,2),RA(X_"VPGR")=$P(RA(X_"PHON"),U,7)
- S RA(X_"DPGR")=$P(RA(X_"PHON"),U,8)
- S RA(X_"PHOINFO")=RA(X_"OPHO")_" / "_RA(X_"VPGR")_" / "_RA(X_"DPGR")
- S:RA(X_"PHOINFO")=" / / " RA(X_"PHOINFO")="Unknown"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAORD5 7745 printed Jan 18, 2025@03:39:07 Page 2
- RAORD5 ;HISC/CAH,FPT,GJC AISC/RMO-Print A Request ; Mar 16, 2023@06:47:25
- +1 ;;5.0;Radiology/Nuclear Medicine;**8,10,15,31,45,75,123,132,149,200**;Mar 16, 1998;Build 2
- +2 ; Input: RADFN= Internal Number to Rad/Nuc Med Patient File #70
- +3 ; RAOIFN= Internal Number to Rad/Nuc Med Orders File #75.1
- +4 ; RAX= Null (Used to check for an '^')
- +5 ; RAPGE= 0 (Used as a page counter)
- +6 ;
- +7 ; Supported IA #1120 reference to EN6^GMRVUTL 5-P123,5-132
- +8 ; Reference to ^SC(D0,99) is supported by ICR #4782
- +9 ;
- +10 ; 1-p75 10/12/2006 GJC RA*5*75 Remedy 162508 Modify Patient AGE calc
- +11 ; 2-p75 10/12/2006 GJC RA*5*75 set REASON FOR STUDY to a local variable
- +12 ; 5-P123 6/23/2015 MJT RA*5*123 NSR 20140507 print weight & date taken in Radiology requests
- +13 ; 5-P132 11/1/2017 RTW RA*5*123 NSR 20160706 print height & date taken in Radiology requests
- +14 ; 1-p200 3/01/2023 KLM RA*5*200 NSR 20220815 add patient's preferred name to patient name variable
- +15 ;
- +16 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +17 NEW DFN,GMRVSTR,RAHDX,RAPROC,RAPREFNM
- +18 if '$DATA(^DPT(RADFN,0))
- GOTO Q
- SET RADPT0=^(0)
- if '$DATA(^RAO(75.1,RAOIFN,0))
- GOTO Q
- SET RAORD0=^(0)
- +19 ;1-p200 get patient preferred name.
- SET RAPREFNM=$$GET1^DIQ(2,RADFN,.2405)
- +20 SET RAPROC=$PIECE(RAORD0,"^",2)
- +21 KILL ^UTILITY($JOB,"W"),^(1)
- SET RAOSTSYM="dc^c^h^^p^^^s"
- SET $PIECE(RALNE,"-",79)=""
- SET $PIECE(RALNE1,"=",79)=""
- SET DIWL=5
- SET DIWR=75
- SET DIWF="WC75"
- +22 ;1-p200 - Append preferred name in parenthesis: PT NAME (PRF NAME)
- SET RA("NME")=$PIECE(RADPT0,"^")
- IF RAPREFNM]""
- SET RA("NME")=RA("NME")_" ("_RAPREFNM_")"
- +23 SET RA("SEX")=$PIECE(RADPT0,"^",2)
- SET RA("DOB")=$PIECE(RADPT0,"^",3)
- SET RASSN=$$SSN^RAUTL
- +24 ;1-p75
- SET RA("AGE")=($$FMDIFF^XLFDT($PIECE(RAORD0,U,16),RA("DOB")))\365.25
- +25 ;2-p75
- SET RA("STY_REA")=$PIECE($GET(^RAO(75.1,RAOIFN,.1)),U)
- +26 SET RA("PRC NODE")=$GET(^RAMIS(71,+RAPROC,0))
- +27 SET RA("PRC")=$EXTRACT($PIECE(RA("PRC NODE"),U),1,36)
- +28 SET RA("PRC")=$SELECT(RA("PRC")]"":RA("PRC"),1:"UNKNOWN")
- +29 SET RA("PRCTY")=$PIECE(RA("PRC NODE"),U,6)
- +30 ;$$XTERNAL^RAUTL5(RA("PRCTY"),$P($G(^DD(71,6,0)),U,2))
- SET RA("PRCTY")=$$GET1^DIQ(71,RAPROC_",",6)
- +31 SET RA("PRCTY")=$EXTRACT(RA("PRCTY"))_$$LOW^XLFSTR($EXTRACT(RA("PRCTY"),2,99))
- +32 SET RA("CPT")=+$PIECE(RA("PRC NODE"),U,9)
- +33 SET RA("CPT")=$PIECE($$NAMCODE^RACPTMSC(RA("CPT"),DT),U)
- +34 SET RA("PRCIT")=+$PIECE(RA("PRC NODE"),U,12)
- +35 SET RA("PRCIT")=$PIECE($GET(^RA(79.2,RA("PRCIT"),0)),U,3)
- +36 SET RA("CNCAT")="("_RA("PRCIT")_" "_RA("PRCTY")_" "_RA("CPT")_")"
- +37 SET RA("PRC INFO")=""
- SET $EXTRACT(RA("PRC INFO"),1,36)=RA("PRC")
- +38 SET $EXTRACT(RA("PRC INFO"),38,60)=RA("CNCAT")
- KILL RA("CNCAT")
- +39 SET RA("PRC MSG")=$SELECT(+$ORDER(^RAMIS(71,+$PIECE(RAORD0,"^",2),3,0))>0:1,1:0)
- +40 ;$P($P(^DD(75.1,6,0),$P(RAORD0,"^",6)_":",2),";")
- SET RA("OUG")=$$GET1^DIQ(75.1,RAOIFN_",",6)
- +41 KILL RA("MOD")
- FOR I=0:0
- SET I=$ORDER(^RAO(75.1,RAOIFN,"M","B",I))
- if 'I
- QUIT
- IF $DATA(^RAMIS(71.2,+I,0))
- SET RA("MOD")=$SELECT('$DATA(RA("MOD")):$PIECE(^(0),"^"),1:RA("MOD")_", "_$PIECE(^(0),"^"))
- if $PIECE($GET(^(0)),U,2)="p"
- SET RA("PORTABLE")=""
- +42 SET RA("OST")=$$GET1^DIQ(75.1,RAOIFN_",",5)_$SELECT($PIECE(RAOSTSYM,"^",$PIECE(RAORD0,"^",5))="":"",1:" ("_$PIECE(RAOSTSYM,"^",$PIECE(RAORD0,"^",5))_")")
- +43 SET RA("PHY")=$SELECT($DATA(^VA(200,+$PIECE(RAORD0,"^",14),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
- +44 ; Requesting Physician Phone info
- +45 if RA("PHY")'="UNKNOWN"
- DO PHONE("R",+$PIECE(RAORD0,"^",14))
- +46 ; Get current primary and attending physicians
- +47 SET DFN=RADFN
- SET VA200=1
- DO IN5^VADPT
- KILL VA200
- if '$DATA(VAIP(18))
- SET VAIP(18)=""
- +48 ; *** NSR 20140507 Start Mod to print weight & date taken in Radiology requests 5-P123 ***
- +49 SET DFN=RADFN
- SET GMRVSTR="WT"
- +50 DO EN6^GMRVUTL
- +51 SET RA("WT")=$PIECE(X,U,8)
- SET Y=$PIECE(X,U)
- DO DD^%DT
- SET RA("WTDT")=Y
- +52 ;RTW BEGIN RA*5.0*132 ADD HEIGHT
- +53 SET DFN=RADFN
- SET GMRVSTR="HT"
- +54 DO EN6^GMRVUTL
- SET RAHDX=$GET(X)
- +55 SET Y=$PIECE(RAHDX,U,1)
- IF Y>0
- DO DD^%DT
- SET RA("HTDT")=Y
- +56 SET RA("HT")=$PIECE(RAHDX,U,8)
- +57 ;RTW END RA*5.0*132 ADD HEIGHT
- +58 ; actual print code located in RAORD6
- +59 ; *** NSR 20140507 End Mod to print weight & date taken in Radiology requests ***
- +60 IF '+$GET(VAIP(7))
- Begin DoDot:1
- +61 ; If the Primary Physician is not found (based on inpatient episode)
- +62 ; find the current Primary Care Practitioner (See patch SD*5.3*30)
- +63 ; VAIP(7) is null at this point. VAIP(7) will exit this DO block
- +64 ; set to the Primary Care Practitioner or null.
- +65 NEW X
- SET X="SDUTL3"
- XECUTE ^%ZOSF("TEST")
- +66 if $TEST
- SET VAIP(7)=$$OUTPTPR^SDUTL3(RADFN)
- +67 QUIT
- End DoDot:1
- +68 ; Get Current Primary and Attending Physician Phone info
- +69 SET RA("ATTEN")=$SELECT($PIECE(VAIP(18),"^",2)]"":$PIECE(VAIP(18),"^",2),1:"UNKNOWN")
- +70 if RA("ATTEN")'="UNKNOWN"
- DO PHONE("A",+$GET(VAIP(18)))
- +71 SET RA("PRIM")=$SELECT($PIECE(VAIP(7),"^",2)]"":$PIECE(VAIP(7),"^",2),1:"UNKNOWN")
- +72 if RA("PRIM")'="UNKNOWN"
- DO PHONE("P",+$GET(VAIP(7)))
- +73 ; Requesting location, room-bed
- +74 SET RA("HLC")=$SELECT($DATA(^SC(+$PIECE(RAORD0,"^",22),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
- SET RA("HPH")=$SELECT($DATA(^SC(+$PIECE(RAORD0,"^",22),99)):$PIECE(^(99),"^"),1:"")
- IF VAIP(1)
- SET RA("ROOM-BED")=$SELECT(+VAIP(6):$PIECE(VAIP(6),"^",2),1:"")
- +75 ; Get primary and attending phys as of order date and their phone, etc.
- +76 KILL RA("ODT")
- SET Y=$PIECE(RAORD0,"^",16)
- IF Y
- if $PIECE(Y,".",2)
- SET Y=$PIECE(Y,".")_"."_$$NOSECNDS^RAORD3($PIECE(Y,".",2))
- SET RA("ODT")=$$FMTE^XLFDT(Y,"1P")
- +77 KILL VAIP
- SET DFN=RADFN
- SET VAIP("D")=+$PIECE(RAORD0,"^",16)
- SET VA200=1
- if VAIP("D")
- DO IN5^VADPT
- KILL VA200
- +78 SET RA("OATTEN")=$SELECT($PIECE($GET(VAIP(18)),"^",2)]"":$PIECE(VAIP(18),"^",2),1:"UNKNOWN")
- +79 if RA("OATTEN")'="UNKNOWN"
- DO PHONE("OA",+$GET(VAIP(18)))
- +80 SET RA("OPRIM")=$SELECT($PIECE($GET(VAIP(7)),"^",2)]"":$PIECE(VAIP(7),"^",2),1:"UNKNOWN")
- +81 if RA("OPRIM")'="UNKNOWN"
- DO PHONE("OP",+$GET(VAIP(7)))
- +82 ; Get other order info (orderer, transport mode, etc.)
- +83 ;S RA("USR")=$S($D(^VA(200,+$P(RAORD0,"^",15),0)):$P(^(0),"^"),1:"UNKNOWN"),RA("TRAN")=$S($P(RAORD0,"^",19)']"":"UNKNOWN",1:$P($P(^DD(75.1,19,0),$P(RAORD0,"^",19)_":",2),";")) S:$P(RAORD0,"^",19)="p" RA("PORTABLE")=""
- +84 SET RA("USR")=$SELECT($DATA(^VA(200,+$PIECE(RAORD0,"^",15),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
- SET RA("TRAN")=$SELECT($PIECE(RAORD0,"^",19)="":"UNKNOWN",1:$$GET1^DIQ(75.1,RAOIFN_",",19))
- if $PIECE(RAORD0,"^",19)="p"
- SET RA("PORTABLE")=""
- +85 KILL RA("ST"),^TMP($JOB,"RA DIFF PRC")
- +86 ;determine if ordered procedure has CM assoc.; return null if none
- +87 SET RACMFLG("O")=$$CMEDIA^RAO7UTL(+$PIECE(RAORD0,U,2),$PIECE(RA("PRC NODE"),U,6))
- +88 ; If appropriate, determine exam status and descendant exams
- +89 IF $DATA(^RADPT("AO",RAOIFN,RADFN))
- DO DPRC^RAORD2(RAOIFN,RADFN)
- +90 SET RADIV(0)=$GET(^SC(+$PIECE(RAORD0,"^",22),0))
- +91 SET RADIV=+$$SITE^VASITE(DT,+$PIECE(RADIV(0),"^",15))
- if RADIV<0
- SET RADIV=0
- +92 SET RADIV=$SELECT($DATA(^RA(79,RADIV,0)):RADIV,1:$ORDER(^RA(79,0)))
- +93 SET RADIVPAR=$SELECT($DATA(^RA(79,+RADIV,.1)):^(.1),1:"")
- +94 KILL RA("RDT")
- SET Y=$PIECE(RAORD0,"^",21)
- IF Y
- if $PIECE(Y,".",2)
- SET Y=$PIECE(Y,".")_"."_$$NOSECNDS^RAORD3($PIECE(Y,".",2))
- SET RA("RDT")=$$FMTE^XLFDT(Y,"1P")
- +95 KILL RA("PDT")
- SET Y=$PIECE(RAORD0,"^",12)
- IF Y
- if $PIECE(Y,".",2)
- SET Y=$PIECE(Y,".")_"."_$$NOSECNDS^RAORD3($PIECE(Y,".",2))
- SET RA("PDT")=$$FMTE^XLFDT(Y,"1P")
- +96 KILL RA("VDT")
- SET Y=$PIECE(RAORD0,"^",17)
- IF Y
- if $PIECE(Y,".",2)
- SET Y=$PIECE(Y,".")_"."_$$NOSECNDS^RAORD3($PIECE(Y,".",2))
- SET RA("VDT")=$$FMTE^XLFDT(Y,"1P")
- +97 KILL RA("SDT")
- SET Y=$PIECE(RAORD0,"^",23)
- IF Y
- if $PIECE(Y,".",2)
- SET Y=$PIECE(Y,".")_"."_$$NOSECNDS^RAORD3($PIECE(Y,".",2))
- SET RA("SDT")=$$FMTE^XLFDT(Y,"1P")
- +98 SET RA("ILC")=$SELECT('$PIECE(RAORD0,"^",20):"UNKNOWN",'$DATA(^RA(79.1,+$PIECE(RAORD0,"^",20),0)):"UNKNOWN",$DATA(^SC(+^(0),0)):$PIECE(^(0),"^"),1:"UNKNOWN")
- +99 DO ^RAORD6
- +100 ;
- Q KILL DIWF,DIWL,DIWR,I,RA,RABARC,RABARC0,RABARC1,RADIV,RADIVPAR,RADPT0,RALNE,RALNE1,RAORD0,RAOSTSYM,RATAB,RAV,RASSN,RAXX,VA200,VAERR,VAIP,X,X1,X2,X3,Y,ZZ
- +1 KILL RACMFLG,RALOC,^TMP($JOB,"RA DIFF PRC")
- +2 QUIT
- PHONE(X,Y) ; Setup phone information for Resident Physicians, Attending
- +1 ; Physicians, and Primary Physicians.
- +2 ; 'X' -> $S('A':'Attending','OA':'Old Attending','OP':'Old Primary',
- +3 ; ,'P':'Primary','R':'Resident')
- +4 ; 'Y' -> ien for file 200
- +5 ; RA(X_"PHON")=Phone node <> RA(X_"OPHO")=Office phone
- +6 ; RA(X_"VPGR")=Voice pager <> RA(X_"DPGR")=Digital pager
- +7 ; RA(X_"PHOINFO")=office phone/voice pager/digital pager
- +8 SET RA(X_"PHON")=$GET(^VA(200,+Y,.13))
- +9 SET RA(X_"OPHO")=$PIECE(RA(X_"PHON"),U,2)
- SET RA(X_"VPGR")=$PIECE(RA(X_"PHON"),U,7)
- +10 SET RA(X_"DPGR")=$PIECE(RA(X_"PHON"),U,8)
- +11 SET RA(X_"PHOINFO")=RA(X_"OPHO")_" / "_RA(X_"VPGR")_" / "_RA(X_"DPGR")
- +12 if RA(X_"PHOINFO")=" / / "
- SET RA(X_"PHOINFO")="Unknown"
- +13 QUIT