RAORDC1 ;HISC/GJC-Continuation of the RAORDC routine. ;6/19/97 08:28
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
;
EXMCOM ; Called from EXMCOM^RAORDC, for updating request statuses for
; complete exams.
K RAPRC,RACAT,RAPIFN,RARSH,RASHA,RAMIFN,RAMOD,RAMODA,RAMODD
N RAPRGST S RAPRGST=$P(RAORD0,"^",13)
I $P($G(RAEXM0),"^",25) D D SETU Q
. N %,D,D0,DI,DIC,DIE,DQ,DR,X,Y
. S DIE="^RAO(75.1,",DR="11///Y",DA=RAOIFN D ^DIE
. Q
S:$P(RAEXM0,"^",2)'=$P(RAORD0,"^",2) RAPRC=$P(RAEXM0,"^",2)
S:$P(RAEXM0,"^",4)'=$P(RAORD0,"^",4) RACAT=""""_$P(RAEXM0,"^",4)_""""
S RARSH=$S($P(RAORD0,"^",4)="R"&($P(RAEXM0,"^",4)'="R"):"@",$P(RAEXM0,"^",4)="R"&($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"R"))):"^S X="_""""_^("R")_"""",1:"") K:RARSH="" RARSH
S RASHA=$S("CS"[$P(RAORD0,"^",4)&("CS"'[$P(RAEXM0,"^",4)):"@","CS"[$P(RAEXM0,"^",4)&($P(RAEXM0,"^",9)'=""):"^S X="_$P(RAEXM0,"^",9),1:"") K:RASHA="" RASHA
S:$P(RAEXM0,"^",14)'=$P(RAORD0,"^",14)&($P(RAEXM0,"^",14)) RAPIFN=$P(RAEXM0,"^",14)
; don't del/add modifiers to order file
; remove most fields from DR string to prevent chang'g them in the order
S DA=RAOIFN,DIE="^RAO(75.1,",DR="11////^S X=""n"""
D ^DIE K DE,DQ,DIE,DR
K RAMOD F I=0:0 S I=$O(^RAO(75.1,RAOIFN,"M","B",I)) Q:'I I $D(^RAMIS(71.2,+I,0)) S RAMOD=$S('$D(RAMOD):$P(^(0),"^"),1:RAMOD_", "_$P(^(0),"^"))
SETU ; above code is skipped if procedure is parent
S $P(RABLNK," ",40)=""
I $$ORVR^RAORDU()=2.5,$D(^RAO(75.1,+RAOIFN,0)),$D(^RAMIS(71,+$P(^(0),"^",2),0)) S (RAPRC,ORETURN("ORTX",1))=$E($P(^(0),"^"),1,40)_"," D
.I $D(RAMOD) S ORETURN("ORTX",2)="Modifiers: "_$E(RAMOD,1,80)_","
.S ORETURN("ORTX",3)="Urgency: "_$S($P(RAORD0,"^",6)=1:"STAT",$P(RAORD0,"^",6)=2:"URGENT",1:"ROUTINE")_","
.I $P(RAORD0,"^",19)]"" S X=$P(RAORD0,"^",19),ORETURN("ORTX",3)=ORETURN("ORTX",3)_" Transport: "_$S(X="a":"AMBULATORY",X="p":"PORTABLE",X="s":"STRETCHER",1:"WHEELCHAIR")_","
.I $P($G(^DPT(+RADFN,0)),"^",2)'="M" S ORETURN("ORTX",3)=ORETURN("ORTX",3)_" Pregnant: "_$S(RAPRGST="n":"NO",RAPRGST="y":"YES",RAPRGST="u":"UNKNOWN",1:"")
.S ORETURN("ORIT")=$P(^RAO(75.1,+RAOIFN,0),"^",2)_";RAMIS(71,"
I '$D(RAF1),('$P(RAEXM0,"^",25)) D ; if orphan, display text now
. W !?3,"...will now designate request status as 'COMPLETE'..."
. Q
D ^RAORDU ; Update the request status
I '$D(RAF1),('$P(RAEXM0,"^",25)) D ; if orphan, display text now
. W !?10,"...request status successfully updated."
. Q
Q
RAORDC1 ;HISC/GJC-Continuation of the RAORDC routine. ;6/19/97 08:28
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+2 ;
EXMCOM ; Called from EXMCOM^RAORDC, for updating request statuses for
+1 ; complete exams.
+2 KILL RAPRC,RACAT,RAPIFN,RARSH,RASHA,RAMIFN,RAMOD,RAMODA,RAMODD
+3 NEW RAPRGST
SET RAPRGST=$PIECE(RAORD0,"^",13)
+4 IF $PIECE($GET(RAEXM0),"^",25)
Begin DoDot:1
+5 NEW %,D,D0,DI,DIC,DIE,DQ,DR,X,Y
+6 SET DIE="^RAO(75.1,"
SET DR="11///Y"
SET DA=RAOIFN
DO ^DIE
+7 QUIT
End DoDot:1
DO SETU
QUIT
+8 IF $PIECE(RAEXM0,"^",2)'=$PIECE(RAORD0,"^",2)
SET RAPRC=$PIECE(RAEXM0,"^",2)
+9 IF $PIECE(RAEXM0,"^",4)'=$PIECE(RAORD0,"^",4)
SET RACAT=""""_$PIECE(RAEXM0,"^",4)_""""
+10 SET RARSH=$SELECT($PIECE(RAORD0,"^",4)="R"&($PIECE(RAEXM0,"^",4)'="R"):"@",$PIECE(RAEXM0,"^",4)="R"&($DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"R"))):"^S X="_""""_^("R")_"""",1:"")
IF RARSH=""
KILL RARSH
+11 SET RASHA=$SELECT("CS"[$PIECE(RAORD0,"^",4)&("CS"'[$PIECE(RAEXM0,"^",4)):"@","CS"[$PIECE(RAEXM0,"^",4)&($PIECE(RAEXM0,"^",9)'=""):"^S X="_$PIECE(RAEXM0,"^",9),1:"")
IF RASHA=""
KILL RASHA
+12 IF $PIECE(RAEXM0,"^",14)'=$PIECE(RAORD0,"^",14)&($PIECE(RAEXM0,"^",14))
SET RAPIFN=$PIECE(RAEXM0,"^",14)
+13 ; don't del/add modifiers to order file
+14 ; remove most fields from DR string to prevent chang'g them in the order
+15 SET DA=RAOIFN
SET DIE="^RAO(75.1,"
SET DR="11////^S X=""n"""
+16 DO ^DIE
KILL DE,DQ,DIE,DR
+17 KILL RAMOD
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 RAMOD=$SELECT('$DATA(RAMOD):$PIECE(^(0),"^"),1:RAMOD_", "_$PIECE(^(0),"^"))
SETU ; above code is skipped if procedure is parent
+1 SET $PIECE(RABLNK," ",40)=""
+2 IF $$ORVR^RAORDU()=2.5
IF $DATA(^RAO(75.1,+RAOIFN,0))
IF $DATA(^RAMIS(71,+$PIECE(^(0),"^",2),0))
SET (RAPRC,ORETURN("ORTX",1))=$EXTRACT($PIECE(^(0),"^"),1,40)_","
Begin DoDot:1
+3 IF $DATA(RAMOD)
SET ORETURN("ORTX",2)="Modifiers: "_$EXTRACT(RAMOD,1,80)_","
+4 SET ORETURN("ORTX",3)="Urgency: "_$SELECT($PIECE(RAORD0,"^",6)=1:"STAT",$PIECE(RAORD0,"^",6)=2:"URGENT",1:"ROUTINE")_","
+5 IF $PIECE(RAORD0,"^",19)]""
SET X=$PIECE(RAORD0,"^",19)
SET ORETURN("ORTX",3)=ORETURN("ORTX",3)_" Transport: "_$SELECT(X="a":"AMBULATORY",X="p":"PORTABLE",X="s":"STRETCHER",1:"WHEELCHAIR")_","
+6 IF $PIECE($GET(^DPT(+RADFN,0)),"^",2)'="M"
SET ORETURN("ORTX",3)=ORETURN("ORTX",3)_" Pregnant: "_$SELECT(RAPRGST="n":"NO",RAPRGST="y":"YES",RAPRGST="u":"UNKNOWN",1:"")
+7 SET ORETURN("ORIT")=$PIECE(^RAO(75.1,+RAOIFN,0),"^",2)_";RAMIS(71,"
End DoDot:1
+8 ; if orphan, display text now
IF '$DATA(RAF1)
IF ('$PIECE(RAEXM0,"^",25))
Begin DoDot:1
+9 WRITE !?3,"...will now designate request status as 'COMPLETE'..."
+10 QUIT
End DoDot:1
+11 ; Update the request status
DO ^RAORDU
+12 ; if orphan, display text now
IF '$DATA(RAF1)
IF ('$PIECE(RAEXM0,"^",25))
Begin DoDot:1
+13 WRITE !?10,"...request status successfully updated."
+14 QUIT
End DoDot:1
+15 QUIT
