RAORD6 ;HISC/CAH - AISC/RMO-Print A Request Cont. ; 06 Oct 2013 10:47 AM
;;5.0;Radiology/Nuclear Medicine;**5,10,15,18,27,45,41,75,85,99,1003**;Nov 01, 2010;Build 13
; 3-p75 10/12/2006 GJC RA*5*75 print Reason for Study
; 4-p75 10/12/2006 KAM RA*5*75 display the request print date in the header
; 5-p75 10/12/2006 KAM RA*5*75 update header "Age" to "Age at req"
; 6-p85 06/20/2007 KAM RA*5*85 Reason for Study/Bar Code print issue
; Remedy Call - 193859
;Supported IA #10104 reference to ^XLFSTR
;Supported IA #10060 reference to ^VA(200
D HD Q:RAX["^"
;
;IHS/BJI/DAY - Patch 1005 - Gender Fix
;I $$PTSEX^RAUTL8(RADFN)="F" D ;display pregnancy status for females ptch 45
I $$PTSEX^RAUTL8(RADFN)'="M" D
.;
.W !,"Pregnant at time of order entry: ",?22,$S($P(RAORD0,"^",13)="y":"YES",$P(RAORD0,"^",13)="n":"NO",1:"UNKNOWN")
.Q:'$D(RAOIFN)
.Q:'$D(^RADPT("AO",$G(RAOIFN),RADFN))
.N RAINVDT,RA5
.S RAINVDT=$O(^RADPT("AO",RAOIFN,RADFN,0))
.Q:'$G(RAINVDT)
.S RA5=$O(^RADPT("AO",RAOIFN,RADFN,RAINVDT,0))
.Q:'$G(RA5)
.N R3,RAPCOMM S R3=$G(^RADPT(RADFN,"DT",$G(RAINVDT),"P",$G(RA5),0))
.S RAPCOMM=$G(^RADPT(RADFN,"DT",+$G(RAINVDT),"P",+$G(RA5),"PCOMM"))
.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:"")
.W:$P(R3,U,32)'="n"&$L(RAPCOMM) !,"Pregnancy Screen Comment: ",RAPCOMM
.Q
W:$P(RAORD0,"^",24)="y" !!?12,"*** Universal Isolation Precautions ***"
W:$D(RA("VDT")) !!?8,"** Note Request Associated with Visit on ",RA("VDT")," **"
W !!,"Requested:",?18,RA("PRC INFO")
;
I $D(^TMP($J,"RA DIFF PRC")),('$D(RAFOERR)),('$D(RAOPT("REG"))),('$D(RAOPT("ORDEREXAM"))),('$D(RAOPT("ADDEXAM"))) D Q:RAX["^"
. ; don't print registered procedure info (CPT, Proc Type, Imaging
. ; Type) if entering through 'Request An Exam', 'Register Patient
. ; for Exams' or 'Add Exams To Last Visit'. Don't print if ordered
. ; through ANY version of OE/RR. If ordered through OE/RR, RAFOERR
. ; will be defined. (Set in RAORD1 & RAO7RO)
. N RAT,RA18NLIN S RAT="",RA18NLIN=0 W !,"Registered:"
. F S RAT=$O(^TMP($J,"RA DIFF PRC",RAT)) Q:RAT="" D Q:RAX["^"
.. D HD:($Y+6)>IOSL Q:RAX["^"
.. W:RA18NLIN ! W ?12,RAT
.. S RA18NLIN=1
.. Q
. Q
I $G(RACMFLG("O"))'="" W !?12,"** The requested procedure has contrast media assigned **"
I $G(RACMFLG("R"))'="" W !?12,"** A registered procedure uses contrast media **"
W:$D(RA("MOD")) !,"Procedure Modifiers:",?22,RA("MOD")
I RA("PRC MSG") D Q:RAX["^"
. N A,B,C,X S (A,C)=0 W !,"Procedure Message: ",!
. F S A=$O(^RAMIS(71,+$P(RAORD0,"^",2),3,A)) Q:A'>0!(RAX["^") D
.. S B=+$G(^RAMIS(71,+$P(RAORD0,"^",2),3,A,0))
.. S X=$G(^RAMIS(71.4,B,0))
.. W:'C ?3,"-" W:C !?3,"-"
.. D OUTTEXT^RAUTL9(X,"",5,80,4,"","!")
.. D HD:($Y+6)>IOSL S C=C+1
.. Q
. Q
W !,"Request Status:",?22,$E(RA("OST"),1,24)
I $P(RAORD0,"^",5)=1!($P(RAORD0,"^",5)=3) D Q:RAX["^"
. W !,"Reason ",$S($P(RAORD0,"^",5)=1:"Cancelled",1:"Held"),":"
. W ?22,$S($D(^RA(75.2,+$P(RAORD0,"^",10),0)):$E($P(^(0),"^"),1,50),$P(RAORD0,"^",27)]"":$E($P(RAORD0,"^",27),1,50),1:"UNKNOWN")
. D HD:($Y+6)>IOSL Q:RAX["X"
. I $D(^RAO(75.1,RAOIFN,1)) D Q:RAX["^"
.. N X,I,RAXX
.. K ^UTILITY($J,"W")
.. W !,"Hold Description:",!
.. S I=0 F S I=$O(^RAO(75.1,RAOIFN,1,I)) Q:'I S (RAXX,X)=^(I,0) D HD:($Y+6)>IOSL Q:RAX["^" S X=RAXX D ^DIWP
.. Q:RAX["^"
.. D HD:($Y+6)>IOSL Q:RAX["X"
.. D ^DIWW:$D(RAXX)
.. D HD:($Y+6)>IOSL Q:RAX["X"
. I $P(RAORD0,"^",5)=1 D
.. W !!,?(IOM-(IOM/2+15)),"*********************",!,?(IOM-(IOM/2+15)),"* C A N C E L L E D *",!,?(IOM-(IOM/2+15)),"*********************"
W:$P(RAORD0,"^",5)=6&($D(RA("ST"))) !,"Exam Status:",?22,RA("ST")
W:$P(RAORD0,"^",5)=8&($D(RA("SDT"))) !,"Exam Scheduled:",?22,RA("SDT")
D HD:($Y+6)>IOSL Q:RAX["^"
W !!,"Requester:",?22,$E(RA("PHY"),1,20)
W:RA("PHY")'="UNKNOWN" !?1,"Tel/Page/Dig Page: ",$G(RA("RPHOINFO"))
D HD:($Y+6)>IOSL Q:RAX["^"
W !,"Attend Phy Current:",?22,$E(RA("ATTEN"),1,20)
W:RA("ATTEN")'="UNKNOWN" !?1,"Tel/Page/Dig Page: ",$G(RA("APHOINFO"))
D HD:($Y+6)>IOSL Q:RAX["^"
W !,"Prim Phy Current:",?22,$E(RA("PRIM"),1,20)
W:RA("PRIM")'="UNKNOWN" !?1,"Tel/Page/Dig Page: ",$G(RA("PPHOINFO"))
K RAPASS1,RAPASS2
S RAPASS1=RA("ATTEN"),RAPASS2=RA("OATTEN")
D HD:($Y+6)>IOSL Q:RAX["^"
I $$ID^RAORD6(RAPASS1,RAPASS2) D
. W !,"Attend Phy At Order:",?22,$E(RA("OATTEN"),1,20)
. W:RA("OATTEN")'="UNKNOWN" !?1,"Tel/Page/Dig Page: ",$G(RA("OAPHOINFO"))
. Q
S RAPASS1=RA("PRIM"),RAPASS2=RA("OPRIM")
I $$ID^RAORD6(RAPASS1,RAPASS2) D
. W !,"Prim Phy At Order:",?22,$E(RA("OPRIM"),1,20)
. W:RA("OPRIM")'="UNKNOWN" !?1,"Tel/Page/Dig Page: ",$G(RA("OPPHOINFO"))
. Q
K RAPASS1,RAPASS2
I +$P(RAORD0,"^",8) D
. N RAPPRAD S RAPPRAD=+$P(RAORD0,"^",8)
. S:$P($G(^VA(200,RAPPRAD,20)),"^",2)]"" RAPPRAD=$P(^(20),"^",2)
. S:RAPPRAD=+RAPPRAD RAPPRAD=$P(^VA(200,RAPPRAD,0),"^")
. W !,"Approved by: ",?22,RAPPRAD
. Q
D HD:($Y+6)>IOSL Q:RAX["^"
W !,"Date/Time Ordered:",?22,$S($D(RA("ODT")):RA("ODT"),1:"")," by ",$E(RA("USR"),1,20)
W:$D(RA("RDT")) !,"Date Desired:",?22,RA("RDT")
D:$P(RAORD0,"^",5)=1 USERCAN^RAORD3
D HD:($Y+6)>IOSL Q:RAX["^"
W:$D(RA("PDT")) !,"Pre-op Date/Time:",?22,RA("PDT"),!!?26,"**** P R E - O P ****",!
BAR ;Print bar-coded SSN on request form if term type has bar code setup
I $G(RASSN)'?3N1"-"2N1"-".E G CONT
S X3=$E(RASSN,1,3)_$E(RASSN,5,6)_$E(RASSN,8,11)
; 06/20/2007 KAM/BAY RA*5*85 Added 2 line feeds
D PSET^%ZISP I IOBARON]"",(IOBAROFF]"") W !!!?49,@IOBARON,X3,@IOBAROFF,!
D PKILL^%ZISP
;
CONT D HD:($Y+6)>IOSL Q:RAX["^" D ODX^RABWUTL(RAOIFN) ; * Billing Aware *
D HD:($Y+6)>IOSL Q:RAX["^"
; 06/20/2007 KAM/BAY RA*5*85 Added line feed to the next line
I $L(RA("STY_REA")) W ! D DIWP^RAUTL5(1,68,"Reason for Study: "_RA("STY_REA")) ;3-p75
D HD:($Y+6)>IOSL Q:RAX["^" K ^UTILITY($J,"W"),^(1) W !,"Clinical History:",! K RAXX F RAV=0:0 S RAV=$O(^RAO(75.1,RAOIFN,"H",RAV)) Q:'RAV I $D(^(RAV,0)) S RAXX=^(0) D HD:($Y+6)>IOSL Q:RAX["^" S X=RAXX D ^DIWP
Q:RAX["^" D HD:($Y+6)>IOSL Q:RAX["^" D ^DIWW:$D(RAXX),HD:($Y+6)>IOSL Q:RAX["^" D WORK ;always print bottom section of form 012601
W ! S BOT=IOSL-($Y+4) S:($E(IOST,1,6)="P-BROW"&($D(DDBRZIS))) BOT=5 F BT=1:1:BOT W !
K BOT,BT
;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler patch from 2004
;Comment out VA form name
;W !,"VA Form 519a-ADP"
;End Patch
Q
;
WORK W !,RALNE,!,"Date Performed: ________________________",?46
I $O(^RADPT("AO",RAOIFN,0))="" W "Case No.: ______________________"
E W "Case No.: ______see above_______"
D HD:($Y+6)>IOSL Q:RAX["^"
W !,"Technologist Initials: _________________"
D HD:($Y+6)>IOSL Q:RAX["^"
W !?46,"Number/Size Films: _____________",!,"Interpreting Phys. Initials: ___________",?65,"_____________",!?65,"_____________",!
D HD:($Y+6)>IOSL Q:RAX["^"
W !,"Comments:"
;
TC D EN30^RAO7PC1(RAOIFN),TC^RAORD61 Q:RAX["^"
;
DASHLN W ! F I=1:1:5 D HD:($Y+6)>IOSL Q:RAX["^" W !,RALNE ;P18
;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler patch from 2004
;Add display of last 5 exams/orders
W:($Y+6)'>IOSL !!,RALNE1 S RACONT="" D HD:($Y+8)>IOSL Q:RAX["^" D EXAM^RADEM1 K RACONT W !,RALNE1
;End Patch
Q
;
HD S:'$D(RAPGE) RAPGE=0 D CRCHK Q:$G(RAX)["^" S RATAB=$S($D(RA("ILC")):1,1:16)
;10/12/2006 KAM Remedy tk 162508 Changed next line added "Printed:"
W:$Y @IOF W !?RATAB,">>"_$S($D(RACRHD):"Discontinued ",1:"")_"Rad/NM Consultation" W:$D(RA("ILC")) " for ",$E(RA("ILC"),1,17) W "<<Printed:" S X="NOW",%DT="T" D ^%DT K %DT D D^RAUTL W ?52,Y ;P18 4-P74
S RAPGE=RAPGE+1 W ?71,"Page ",RAPGE ;P18
W !,RALNE1,!,"Name : ",RA("NME"),?46,"Urgency : ",RA("OUG") W:$D(RA("PORTABLE")) " *PORTABLE*"
W !,"Pt ID Num : ",RASSN,?46,"Transport : ",RA("TRAN")
S Y=RA("DOB") D D^RAUTL W !,"Date of Birth: ",Y,?46,"Patient Loc: ",$E(RA("HLC"),1,20)
;10/12/2006 KAM Remedy Ticket 162508 changed next line
W !,"Age at req : ",RA("AGE"),?46,"Phone Ext : ",RA("HPH") ;5-P75
;
;IHS/BJI/DAY - Patch 1005 - Gender Fix
;W !,"Sex : ",$S(RA("SEX")="M":"MALE",1:"FEMALE") W:$D(RA("ROOM-BED")) ?46,"Room-Bed : ",RA("ROOM-BED") W !,RALNE1
W !,"Sex : ",$S(RA("SEX")="M":"MALE",RA("SEX")="F":"FEMALE",1:"UNKNOWN") W:$D(RA("ROOM-BED")) ?46,"Room-Bed : ",RA("ROOM-BED") W !,RALNE1
;
W:$P(RAORD0,U,5)=1 !,"***C A N C E L L E D***",?56,"***C A N C E L L E D***"
Q
;
CRCHK I RAPGE,$E(IOST)="C" W !!,$C(7),"Press RETURN to continue or '^' to stop " R X:DTIME S RAX=X
Q
ID(X,Y) ; Checks for the following condition:
; 1) Attending Phy. Current & Attending Phy. At Order are the same.
; 2) Primary Phy. Current & Primary Phy. At Order are the same.
; Input Variables:
; 'X'-> Attending/Primary Phy. Current
; 'Y'-> Attending/Primary Phy. At Order
I X']""!(Y']"") Q 0
I $$UP^XLFSTR(X)="UNKNOWN",($$UP^XLFSTR(Y)="UNKNOWN") Q 0
N A,B,Z S A=+$O(^VA(200,"B",X,"")),B=+$O(^VA(200,"B",Y,""))
I A>0,(B>0),(A=B) S Z=0
E S Z=1
Q Z ; $S(Z=1:"different physician",Z=0:"same physician")
RAORD6 ;HISC/CAH - AISC/RMO-Print A Request Cont. ; 06 Oct 2013 10:47 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**5,10,15,18,27,45,41,75,85,99,1003**;Nov 01, 2010;Build 13
+2 ; 3-p75 10/12/2006 GJC RA*5*75 print Reason for Study
+3 ; 4-p75 10/12/2006 KAM RA*5*75 display the request print date in the header
+4 ; 5-p75 10/12/2006 KAM RA*5*75 update header "Age" to "Age at req"
+5 ; 6-p85 06/20/2007 KAM RA*5*85 Reason for Study/Bar Code print issue
+6 ; Remedy Call - 193859
+7 ;Supported IA #10104 reference to ^XLFSTR
+8 ;Supported IA #10060 reference to ^VA(200
+9 DO HD
IF RAX["^"
QUIT
+10 ;
+11 ;IHS/BJI/DAY - Patch 1005 - Gender Fix
+12 ;I $$PTSEX^RAUTL8(RADFN)="F" D ;display pregnancy status for females ptch 45
+13 IF $$PTSEX^RAUTL8(RADFN)'="M"
Begin DoDot:1
+14 ;
+15 WRITE !,"Pregnant at time of order entry: ",?22,$SELECT($PIECE(RAORD0,"^",13)="y":"YES",$PIECE(RAORD0,"^",13)="n":"NO",1:"UNKNOWN")
+16 IF '$DATA(RAOIFN)
QUIT
+17 IF '$DATA(^RADPT("AO",$GET(RAOIFN),RADFN))
QUIT
+18 NEW RAINVDT,RA5
+19 SET RAINVDT=$ORDER(^RADPT("AO",RAOIFN,RADFN,0))
+20 IF '$GET(RAINVDT)
QUIT
+21 SET RA5=$ORDER(^RADPT("AO",RAOIFN,RADFN,RAINVDT,0))
+22 IF '$GET(RA5)
QUIT
+23 NEW R3,RAPCOMM
SET R3=$GET(^RADPT(RADFN,"DT",$GET(RAINVDT),"P",$GET(RA5),0))
+24 SET RAPCOMM=$GET(^RADPT(RADFN,"DT",+$GET(RAINVDT),"P",+$GET(RA5),"PCOMM"))
+25 IF $PIECE(R3,U,32)'=""
WRITE !,"Pregnancy Screen: ",$SELECT($PIECE(R3,"^",32)="y":"Patient answered yes",$PIECE(R3,"^",32)="n":"Patient answered no",$PIECE(R3,"^",32)="u":"Patient is unable to answer or is unsure",1:"")
+26 IF $PIECE(R3,U,32)'="n"&$LENGTH(RAPCOMM)
WRITE !,"Pregnancy Screen Comment: ",RAPCOMM
+27 QUIT
End DoDot:1
+28 IF $PIECE(RAORD0,"^",24)="y"
WRITE !!?12,"*** Universal Isolation Precautions ***"
+29 IF $DATA(RA("VDT"))
WRITE !!?8,"** Note Request Associated with Visit on ",RA("VDT")," **"
+30 WRITE !!,"Requested:",?18,RA("PRC INFO")
+31 ;
+32 IF $DATA(^TMP($JOB,"RA DIFF PRC"))
IF ('$DATA(RAFOERR))
IF ('$DATA(RAOPT("REG")))
IF ('$DATA(RAOPT("ORDEREXAM")))
IF ('$DATA(RAOPT("ADDEXAM")))
Begin DoDot:1
+33 ; don't print registered procedure info (CPT, Proc Type, Imaging
+34 ; Type) if entering through 'Request An Exam', 'Register Patient
+35 ; for Exams' or 'Add Exams To Last Visit'. Don't print if ordered
+36 ; through ANY version of OE/RR. If ordered through OE/RR, RAFOERR
+37 ; will be defined. (Set in RAORD1 & RAO7RO)
+38 NEW RAT,RA18NLIN
SET RAT=""
SET RA18NLIN=0
WRITE !,"Registered:"
+39 FOR
SET RAT=$ORDER(^TMP($JOB,"RA DIFF PRC",RAT))
IF RAT=""
QUIT
Begin DoDot:2
+40 IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
+41 IF RA18NLIN
WRITE !
WRITE ?12,RAT
+42 SET RA18NLIN=1
+43 QUIT
End DoDot:2
IF RAX["^"
QUIT
+44 QUIT
End DoDot:1
IF RAX["^"
QUIT
+45 IF $GET(RACMFLG("O"))'=""
WRITE !?12,"** The requested procedure has contrast media assigned **"
+46 IF $GET(RACMFLG("R"))'=""
WRITE !?12,"** A registered procedure uses contrast media **"
+47 IF $DATA(RA("MOD"))
WRITE !,"Procedure Modifiers:",?22,RA("MOD")
+48 IF RA("PRC MSG")
Begin DoDot:1
+49 NEW A,B,C,X
SET (A,C)=0
WRITE !,"Procedure Message: ",!
+50 FOR
SET A=$ORDER(^RAMIS(71,+$PIECE(RAORD0,"^",2),3,A))
IF A'>0!(RAX["^")
QUIT
Begin DoDot:2
+51 SET B=+$GET(^RAMIS(71,+$PIECE(RAORD0,"^",2),3,A,0))
+52 SET X=$GET(^RAMIS(71.4,B,0))
+53 IF 'C
WRITE ?3,"-"
IF C
WRITE !?3,"-"
+54 DO OUTTEXT^RAUTL9(X,"",5,80,4,"","!")
+55 IF ($Y+6)>IOSL
DO HD
SET C=C+1
+56 QUIT
End DoDot:2
+57 QUIT
End DoDot:1
IF RAX["^"
QUIT
+58 WRITE !,"Request Status:",?22,$EXTRACT(RA("OST"),1,24)
+59 IF $PIECE(RAORD0,"^",5)=1!($PIECE(RAORD0,"^",5)=3)
Begin DoDot:1
+60 WRITE !,"Reason ",$SELECT($PIECE(RAORD0,"^",5)=1:"Cancelled",1:"Held"),":"
+61 WRITE ?22,$SELECT($DATA(^RA(75.2,+$PIECE(RAORD0,"^",10),0)):$EXTRACT($PIECE(^(0),"^"),1,50),$PIECE(RAORD0,"^",27)]"":$EXTRACT($PIECE(RAORD0,"^",27),1,50),1:"UNKNOWN")
+62 IF ($Y+6)>IOSL
DO HD
IF RAX["X"
QUIT
+63 IF $DATA(^RAO(75.1,RAOIFN,1))
Begin DoDot:2
+64 NEW X,I,RAXX
+65 KILL ^UTILITY($JOB,"W")
+66 WRITE !,"Hold Description:",!
+67 SET I=0
FOR
SET I=$ORDER(^RAO(75.1,RAOIFN,1,I))
IF 'I
QUIT
SET (RAXX,X)=^(I,0)
IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
SET X=RAXX
DO ^DIWP
+68 IF RAX["^"
QUIT
+69 IF ($Y+6)>IOSL
DO HD
IF RAX["X"
QUIT
+70 IF $DATA(RAXX)
DO ^DIWW
+71 IF ($Y+6)>IOSL
DO HD
IF RAX["X"
QUIT
End DoDot:2
IF RAX["^"
QUIT
+72 IF $PIECE(RAORD0,"^",5)=1
Begin DoDot:2
+73 WRITE !!,?(IOM-(IOM/2+15)),"*********************",!,?(IOM-(IOM/2+15)),"* C A N C E L L E D *",!,?(IOM-(IOM/2+15)),"*********************"
End DoDot:2
End DoDot:1
IF RAX["^"
QUIT
+74 IF $PIECE(RAORD0,"^",5)=6&($DATA(RA("ST")))
WRITE !,"Exam Status:",?22,RA("ST")
+75 IF $PIECE(RAORD0,"^",5)=8&($DATA(RA("SDT")))
WRITE !,"Exam Scheduled:",?22,RA("SDT")
+76 IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
+77 WRITE !!,"Requester:",?22,$EXTRACT(RA("PHY"),1,20)
+78 IF RA("PHY")'="UNKNOWN"
WRITE !?1,"Tel/Page/Dig Page: ",$GET(RA("RPHOINFO"))
+79 IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
+80 WRITE !,"Attend Phy Current:",?22,$EXTRACT(RA("ATTEN"),1,20)
+81 IF RA("ATTEN")'="UNKNOWN"
WRITE !?1,"Tel/Page/Dig Page: ",$GET(RA("APHOINFO"))
+82 IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
+83 WRITE !,"Prim Phy Current:",?22,$EXTRACT(RA("PRIM"),1,20)
+84 IF RA("PRIM")'="UNKNOWN"
WRITE !?1,"Tel/Page/Dig Page: ",$GET(RA("PPHOINFO"))
+85 KILL RAPASS1,RAPASS2
+86 SET RAPASS1=RA("ATTEN")
SET RAPASS2=RA("OATTEN")
+87 IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
+88 IF $$ID^RAORD6(RAPASS1,RAPASS2)
Begin DoDot:1
+89 WRITE !,"Attend Phy At Order:",?22,$EXTRACT(RA("OATTEN"),1,20)
+90 IF RA("OATTEN")'="UNKNOWN"
WRITE !?1,"Tel/Page/Dig Page: ",$GET(RA("OAPHOINFO"))
+91 QUIT
End DoDot:1
+92 SET RAPASS1=RA("PRIM")
SET RAPASS2=RA("OPRIM")
+93 IF $$ID^RAORD6(RAPASS1,RAPASS2)
Begin DoDot:1
+94 WRITE !,"Prim Phy At Order:",?22,$EXTRACT(RA("OPRIM"),1,20)
+95 IF RA("OPRIM")'="UNKNOWN"
WRITE !?1,"Tel/Page/Dig Page: ",$GET(RA("OPPHOINFO"))
+96 QUIT
End DoDot:1
+97 KILL RAPASS1,RAPASS2
+98 IF +$PIECE(RAORD0,"^",8)
Begin DoDot:1
+99 NEW RAPPRAD
SET RAPPRAD=+$PIECE(RAORD0,"^",8)
+100 IF $PIECE($GET(^VA(200,RAPPRAD,20)),"^",2)]""
SET RAPPRAD=$PIECE(^(20),"^",2)
+101 IF RAPPRAD=+RAPPRAD
SET RAPPRAD=$PIECE(^VA(200,RAPPRAD,0),"^")
+102 WRITE !,"Approved by: ",?22,RAPPRAD
+103 QUIT
End DoDot:1
+104 IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
+105 WRITE !,"Date/Time Ordered:",?22,$SELECT($DATA(RA("ODT")):RA("ODT"),1:"")," by ",$EXTRACT(RA("USR"),1,20)
+106 IF $DATA(RA("RDT"))
WRITE !,"Date Desired:",?22,RA("RDT")
+107 IF $PIECE(RAORD0,"^",5)=1
DO USERCAN^RAORD3
+108 IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
+109 IF $DATA(RA("PDT"))
WRITE !,"Pre-op Date/Time:",?22,RA("PDT"),!!?26,"**** P R E - O P ****",!
BAR ;Print bar-coded SSN on request form if term type has bar code setup
+1 IF $GET(RASSN)'?3N1"-"2N1"-".E
GOTO CONT
+2 SET X3=$EXTRACT(RASSN,1,3)_$EXTRACT(RASSN,5,6)_$EXTRACT(RASSN,8,11)
+3 ; 06/20/2007 KAM/BAY RA*5*85 Added 2 line feeds
+4 DO PSET^%ZISP
IF IOBARON]""
IF (IOBAROFF]"")
WRITE !!!?49,@IOBARON,X3,@IOBAROFF,!
+5 DO PKILL^%ZISP
+6 ;
CONT ; * Billing Aware *
IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
DO ODX^RABWUTL(RAOIFN)
+1 IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
+2 ; 06/20/2007 KAM/BAY RA*5*85 Added line feed to the next line
+3 ;3-p75
IF $LENGTH(RA("STY_REA"))
WRITE !
DO DIWP^RAUTL5(1,68,"Reason for Study: "_RA("STY_REA"))
+4 IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
KILL ^UTILITY($JOB,"W"),^(1)
WRITE !,"Clinical History:",!
KILL RAXX
FOR RAV=0:0
SET RAV=$ORDER(^RAO(75.1,RAOIFN,"H",RAV))
IF 'RAV
QUIT
IF $DATA(^(RAV,0))
SET RAXX=^(0)
IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
SET X=RAXX
DO ^DIWP
+5 ;always print bottom section of form 012601
IF RAX["^"
QUIT
IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
IF $DATA(RAXX)
DO ^DIWW
IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
DO WORK
+6 WRITE !
SET BOT=IOSL-($Y+4)
IF ($EXTRACT(IOST,1,6)="P-BROW"&($DATA(DDBRZIS)))
SET BOT=5
FOR BT=1:1:BOT
WRITE !
+7 KILL BOT,BT
+8 ;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler patch from 2004
+9 ;Comment out VA form name
+10 ;W !,"VA Form 519a-ADP"
+11 ;End Patch
+12 QUIT
+13 ;
WORK WRITE !,RALNE,!,"Date Performed: ________________________",?46
+1 IF $ORDER(^RADPT("AO",RAOIFN,0))=""
WRITE "Case No.: ______________________"
+2 IF '$TEST
WRITE "Case No.: ______see above_______"
+3 IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
+4 WRITE !,"Technologist Initials: _________________"
+5 IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
+6 WRITE !?46,"Number/Size Films: _____________",!,"Interpreting Phys. Initials: ___________",?65,"_____________",!?65,"_____________",!
+7 IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
+8 WRITE !,"Comments:"
+9 ;
TC DO EN30^RAO7PC1(RAOIFN)
DO TC^RAORD61
IF RAX["^"
QUIT
+1 ;
DASHLN ;P18
WRITE !
FOR I=1:1:5
IF ($Y+6)>IOSL
DO HD
IF RAX["^"
QUIT
WRITE !,RALNE
+1 ;IHS/BJI/DAY - Patch 1003 - Continue Chris Saddler patch from 2004
+2 ;Add display of last 5 exams/orders
+3 IF ($Y+6)'>IOSL
WRITE !!,RALNE1
SET RACONT=""
IF ($Y+8)>IOSL
DO HD
IF RAX["^"
QUIT
DO EXAM^RADEM1
KILL RACONT
WRITE !,RALNE1
+4 ;End Patch
+5 QUIT
+6 ;
HD IF '$DATA(RAPGE)
SET RAPGE=0
DO CRCHK
IF $GET(RAX)["^"
QUIT
SET RATAB=$SELECT($DATA(RA("ILC")):1,1:16)
+1 ;10/12/2006 KAM Remedy tk 162508 Changed next line added "Printed:"
+2 ;P18 4-P74
IF $Y
WRITE @IOF
WRITE !?RATAB,">>"_$SELECT($DATA(RACRHD):"Discontinued ",1:"")_"Rad/NM Consultation"
IF $DATA(RA("ILC"))
WRITE " for ",$EXTRACT(RA("ILC"),1,17)
WRITE "<<Printed:"
SET X="NOW"
SET %DT="T"
DO ^%DT
KILL %DT
DO D^RAUTL
WRITE ?52,Y
+3 ;P18
SET RAPGE=RAPGE+1
WRITE ?71,"Page ",RAPGE
+4 WRITE !,RALNE1,!,"Name : ",RA("NME"),?46,"Urgency : ",RA("OUG")
IF $DATA(RA("PORTABLE"))
WRITE " *PORTABLE*"
+5 WRITE !,"Pt ID Num : ",RASSN,?46,"Transport : ",RA("TRAN")
+6 SET Y=RA("DOB")
DO D^RAUTL
WRITE !,"Date of Birth: ",Y,?46,"Patient Loc: ",$EXTRACT(RA("HLC"),1,20)
+7 ;10/12/2006 KAM Remedy Ticket 162508 changed next line
+8 ;5-P75
WRITE !,"Age at req : ",RA("AGE"),?46,"Phone Ext : ",RA("HPH")
+9 ;
+10 ;IHS/BJI/DAY - Patch 1005 - Gender Fix
+11 ;W !,"Sex : ",$S(RA("SEX")="M":"MALE",1:"FEMALE") W:$D(RA("ROOM-BED")) ?46,"Room-Bed : ",RA("ROOM-BED") W !,RALNE1
+12 WRITE !,"Sex : ",$SELECT(RA("SEX")="M":"MALE",RA("SEX")="F":"FEMALE",1:"UNKNOWN")
IF $DATA(RA("ROOM-BED"))
WRITE ?46,"Room-Bed : ",RA("ROOM-BED")
WRITE !,RALNE1
+13 ;
+14 IF $PIECE(RAORD0,U,5)=1
WRITE !,"***C A N C E L L E D***",?56,"***C A N C E L L E D***"
+15 QUIT
+16 ;
CRCHK IF RAPGE
IF $EXTRACT(IOST)="C"
WRITE !!,$CHAR(7),"Press RETURN to continue or '^' to stop "
READ X:DTIME
SET RAX=X
+1 QUIT
ID(X,Y) ; Checks for the following condition:
+1 ; 1) Attending Phy. Current & Attending Phy. At Order are the same.
+2 ; 2) Primary Phy. Current & Primary Phy. At Order are the same.
+3 ; Input Variables:
+4 ; 'X'-> Attending/Primary Phy. Current
+5 ; 'Y'-> Attending/Primary Phy. At Order
+6 IF X']""!(Y']"")
QUIT 0
+7 IF $$UP^XLFSTR(X)="UNKNOWN"
IF ($$UP^XLFSTR(Y)="UNKNOWN")
QUIT 0
+8 NEW A,B,Z
SET A=+$ORDER(^VA(200,"B",X,""))
SET B=+$ORDER(^VA(200,"B",Y,""))
+9 IF A>0
IF (B>0)
IF (A=B)
SET Z=0
+10 IF '$TEST
SET Z=1
+11 ; $S(Z=1:"different physician",Z=0:"same physician")
QUIT Z
