RAORDS ;HISC/CAH,DAD AISC/RMO-Select Patient's Requests ; Nov 08, 2022@12:41:56
;;5.0;Radiology/Nuclear Medicine;**15,21,132,174,196**;Mar 16, 1998;Build 1
; Supported IA #1120 reference to EN6^GMRVUTL 5-132
;p174 changed all references to *7 to $C(7)
;
Q:'$D(RADFN) D HOME^%ZIS K ^TMP($J,"RAORDS"),RAOUT,RAORDS
K ^TMP($J,"PRO-ORD"),^TMP($J,"PRO-REG")
; ^tmp($j,"pro-ord",proc-ien,order-ien) -- outstanding orders
; ^tmp($j,"pro-reg",proc-ien,order-ien) -- actually regist'd procs
S ^TMP($J,"RAORDS","Unknown")=""
S (RACNT,RASEQ,RAPARENT)=0,RAOSTSYM="dc^c^h^^p^^^s"
K RAOSTSNM S X(1)=^DD(75.1,5,0) F I=1:1 S RAOSTS=$P(RAOVSTS,";",I) Q:RAOSTS="" S X=$P($P(X(1),RAOSTS_":",2),";"),RAOSTSNM=$S('$D(RAOSTSNM):X,1:RAOSTSNM_", "_X)
F RALP=1:1 S RAOSTS=$P(RAOVSTS,";",RALP) Q:RAOSTS="" F RAOIFN=0:0 S RAOIFN=$O(^RAO(75.1,"AS",RADFN,RAOSTS,RAOIFN)) Q:'RAOIFN I $D(^RAO(75.1,RAOIFN,0)) S RAORD0=^(0) D SETUTL
I '$D(^TMP($J,"RAORDS"))!('RACNT) W !!?5,"No requests available to select for this patient.",! G Q
F RAOURG=0:0 S RAOURG=$O(^TMP($J,"RAORDS",RAOURG)) Q:'RAOURG!($D(RAOSEL)) F RAODTI=0:0 S RAODTI=$O(^TMP($J,"RAORDS",RAOURG,RAODTI)) Q:'RAODTI!($D(RAOSEL)) D CHKORD
;
Q K ^TMP($J,"RAORDS"),RACNT,RACNT1,RADASH,RADUP,RAERR,RAI,RALCTN,RALOC
K RALP,RANUM,RAOASTS,RAODTE,RAODTI,RAOFNS,RAOIFN,RAOIFNS,RAORD0,RAOSEL
K RAOSTS,RAOSTSNM,RAOSTSYM,RAOURG,RAOVSTS,RAPHY,RAPAR,RAPRC,RAREQ
K RASEL,RASEQ,RAX
Q
;
SETUTL ; Check if option is to be screened. If yes, apply the screen.
I $P($G(^RAMIS(71,+$P(RAORD0,U,2),0)),U,6)="P",$O(^RAMIS(71,+$P(RAORD0,U,2),4,0))'>0 Q ; Parent without descendents
I $D(RAVSTFLG)#2,$P($G(^RAMIS(71,+$P(RAORD0,U,2),0)),U,6)="P" Q ; Cannot choose parent in add exams option
I $D(RASCREEN) D Q:'$D(^TMP($J,"RA L-TYPE",RALCTN))
. S RALCTN=+$P(RAORD0,"^",20)
. S:'RALCTN RALCTN="Unknown" Q:RALCTN="Unknown"
. S RALCTN=$S($D(^RA(79.1,RALCTN,0)):+$P(^(0),"^"),1:"Unknown")
. Q:RALCTN="Unknown"
. S RALCTN=$S($D(^SC(RALCTN,0)):$P(^(0),"^"),1:"Unknown")
. Q
;p196 - referral opt & already referred (field #201)
I ($D(RAOPT("CCR")))&($D(^RAO(75.1,"AC",1,RADFN,RAOIFN))) Q ;RA196 don't list orders already referred.
S RACNT=RACNT+1,^TMP($J,"RAORDS",$S('$P(RAORD0,"^",6):9,1:$P(RAORD0,"^",6)),9999999.9999-$S($P(RAORD0,"^",21):$P(RAORD0,"^",21),1:$P(RAORD0,"^",16)),RAOIFN,RACNT)=RAORD0
; store order's indiv procedures
I $P($G(^RAMIS(71,+$P(RAORD0,U,2),0)),U,6)'="P" S ^TMP($J,"PRO-ORD",$S($P(RAORD0,U,2):$P(RAORD0,U,2),1:0),RAOIFN)="" Q
; for parent orders, must store each descendant's proc ien
S RA6=+$P(RAORD0,U,2),RA7=0
F S RA7=$O(^RAMIS(71,RA6,4,RA7)) Q:'RA7 S ^TMP($J,"PRO-ORD",+$P($G(^(RA7,0)),U),RAOIFN)="DESC"
Q
;
CHKORD F RAOIFN=0:0 S RAOIFN=$O(^TMP($J,"RAORDS",RAOURG,RAODTI,RAOIFN)) Q:'RAOIFN!($D(RAOSEL)) F RACNT1=0:0 S RACNT1=$O(^TMP($J,"RAORDS",RAOURG,RAODTI,RAOIFN,RACNT1)) Q:RACNT1'>0!($D(RAOSEL)) S RAORD0=^(RACNT1) D PRTORD
Q
;
PRTORD D HD:'(RASEQ#8) Q:$D(RAOSEL) S RASEQ=RASEQ+1,RAOIFNS(RASEQ)=RAOIFN,RAPRC=$S($D(^RAMIS(71,+$P(RAORD0,"^",2),0)):$P(^(0),"^"),1:"Unknown"),RAODTE=9999999.9999-RAODTI
S RAPHY=$S($D(^VA(200,+$P(RAORD0,"^",14),0)):$P(^(0),"^"),1:"Unknown"),RALOC=$S($D(^SC(+$P(RAORD0,"^",22),0)):$P(^(0),"^"),1:"Unknown")
N RA6 S RA6=$S($P($G(^RAMIS(71,+$P(RAORD0,U,2),0)),U,6)="P"&($P($G(^(0)),U,18)="Y"):"+",1:"") ;parent proc and single rpt
;//p174 begin //
I $G(RAFLGA)'=2 D ; ;protection if called from RAORD2 or RAREG1 & covered if RAFLGA = 1
.W !,$J(RASEQ,2),?4,$P(RAOSTSYM,"^",+$P(RAORD0,"^",5)),?8,$E($P($P(^DD(75.1,6,0),RAOURG_":",2),";"),1,7),?16,RA6
.W ?17,$E(RAPRC,1,25),?44,$E(RAODTE,4,5)_"/"_$E(RAODTE,6,7)_"/"_(1700+$E(RAODTE,1,3)),?56,$E(RAPHY,1,11),?69,$E(RALOC,1,11)
.W !?17,"(",$S($P(RAORD0,U,20)="":"UNKNOWN",1:$E($P($G(^SC(+$G(^RA(79.1,+$P(RAORD0,U,20),0)),0)),U),1,23)),")"
.Q
E D ;schedule a request display P174
.W !,$J(RASEQ,2),?4,$P(RAOSTSYM,"^",+$P(RAORD0,"^",5)),?8,$E($P($P(^DD(75.1,6,0),RAOURG_":",2),";"),1,7),?16,RA6
.W ?17,$E(RAPRC,1,20),?40,$E(RAODTE,4,5)_"/"_$E(RAODTE,6,7)_"/"_(1700+$E(RAODTE,1,3)),?52,$E($TR($$FMTE^XLFDT($P(RAORD0,U,23),"5F")," ",0),1,10)
.W ?65,$E(RAPHY,1,11)
.W !?17,"(",$S($P(RAORD0,U,20)="":"UNKNOWN",1:$E($P($G(^SC(+$G(^RA(79.1,+$P(RAORD0,U,20),0)),0)),U),1,23)),")"
.W ?65,"("_$E(RALOC,1,11)_")"
.Q
;//p174 end //
D ASKSEL:RACNT=RASEQ
Q
;
HD D ASKSEL:RASEQ Q:$D(RAOSEL) W @IOF,!?16,"**** Requested Exams for ",$E(RANME,1,20)," ****",?65,$J(RACNT,3),?70,"Requests"
;RTW Add height and weight *** BEGIN ***
D ;
.N RAHDVITL,RAHDX,DFN,GMRVSTR,X,Y
.F RAHDVITL="HT","WT" D
.. S DFN=RADFN,GMRVSTR=RAHDVITL
.. D EN6^GMRVUTL S RAHDX=$G(X)
.. W !?2,$E(RAHDVITL),"eight : ",$P(RAHDX,U,8)
.. I $P(RAHDX,U,8)]"" W $S(RAHDVITL="HT":"""",RAHDVITL="WT":" lbs",1:"")
.. S Y=$P(RAHDX,U,1) I Y>0 D D^RAUTL W " on ",Y
.. Q
. Q
;RTW Add height and weight *** END ***
;//p174 begin //
I $G(RAFLGA)'=2 D ;protection if called from RAORD2 or RAREG1 & covered if RAFLGA = 1
.W !?4,"St",?8,"Urgency",?17,"Procedure / (Img. Loc.)",?44,"Desired",?56,"Requester",?69,"Req'g Loc",!?4,"--",?8,"-------",?17,"-------------------------",?44,"----------",?56,"-----------",?69,"-----------"
.Q
E D
.W !?4,"St",?8,"Urgency",?17,"Procedure / (I-Loc.)",?40,"Desired",?52,"Scheduled",?65,"Req Phy / (Loc)"
.W !?4,"--",?8,"-------",?17,"--------------------",?40,"----------",?52,"----------",?65,"---------------"
.Q
;//p174 end //
Q
;
ASKSEL K RADUP,RAORDS S (RAERR,RAI,RANUM)=0
W:$D(RAOPT("REG")) !!,"(Use Pn to replace request 'n' with a Printset procedure.)"
W:'$D(RAOPT("REG")) !
W !,"Select Request(s) 1-",RASEQ,$S($D(RAOFNS):" to "_RAOFNS,1:"")," or '^' to Exit: ",$S(RASEQ<RACNT:"Continue",1:"Exit"),"// " R X:DTIME S:'$T X="^",RAOUT="" S:X["^" RAOSEL=0 Q:X["^"!(X="")
S RAX=X I RAX["?" W !!?3,"Please select the request(s) you want separated by commas or a range",!?3,"of numbers separated by a dash, or a combination of commas and dashes." D HLPSEL G ASKSEL
PARSE I $$UP^XLFSTR(RAX)?1"P".N D DPAR Q ; detail-to-parent
S RAI=RAI+1,RAPAR=$P(RAX,",",RAI) Q:RAPAR="" I RAPAR?.N1"-".N S RADASH="" F RASEL=$P(RAPAR,"-"):1:$P(RAPAR,"-",2) D CHKSEL Q:RAERR
I '$D(RADASH) S RASEL=RAPAR D CHKSEL
K RADASH G ASKSEL:RAERR,PARSE
;
CHKSEL I $D(RADASH),+$P(RAPAR,"-",2)<+$P(RAPAR,"-") S RAERR=1 Q
I RASEL'?.N W !?3,$C(7),"Item ",RASEL," is not a valid selection." S RAERR=1 Q
I '$D(RAOIFNS(RASEL)) W !?3,$C(7),"Item ",RASEL," is not a valid selection." S RAERR=1 Q
I $D(RADUP(RASEL)) W !?3,$C(7),"Item ",RASEL," was already selected." S RAERR=1 Q
I $D(^RAO(75.1,+(RAOIFNS(RASEL)),0)),RAOVSTS'[$P(^(0),"^",5) W !?3,$C(7),"Item ",RASEL," does not have a valid status for this option.",!?3,"Valid statuses are ",RAOSTSNM,"." S RAERR=1 Q
I RAPARENT,$P($G(^RAMIS(71,+$P($G(^RAO(75.1,+RAOIFNS(RASEL),0)),U,2),0)),U,6)="P",('$D(RAOPT("ORDERPRINTPAT"))) D S RAERR=1,RAPARENT=0 Q ; Two parents chosen
. ; check NOT valid during 'Print Selected Requests by Patient' option!
. W !!?3,$C(7),"Only one parent type procedure may be chosen at a time."
. W !?3,"(You have already chosen ",$P($G(^RAMIS(71,RAPARENT,0)),U),".)"
. Q
S RANUM=RANUM+1,RADUP(RASEL)="",RAORDS(RANUM)=RAOIFNS(RASEL),RAOSEL=RANUM
I $P($G(^RAMIS(71,+$P($G(^RAO(75.1,+RAOIFNS(RASEL),0)),U,2),0)),U,6)="P" D
. S RAPARENT=+$P($G(^RAO(75.1,+RAOIFNS(RASEL),0)),U,2)
. Q
Q
;
HLPSEL I $D(RAOSTSNM) W !!?3,"The request(s) must have one of the following statuses",$S($D(RAOFNS):" to "_RAOFNS,1:""),":",!?6,RAOSTSNM
I RAX["??" W !!?3,"Status Symbols: 'dc' - discontinued 'c' - complete 'h' - on hold",!?20,"'p' - pending ' ' - active 's' - scheduled"
Q
DPAR ; convert detail proc to parent
S RASEL=$E(RAX,2,$L(RAX)) ; remove leading 'P'
S:RASEL="" RASEL="P" ;set to 1 char so chksel will reject it
D CHKSEL
; if order's proc is a parent, then --
; 1-kill raords to skip exam^rareg1
; 2-don't kill raosel so chkord loop would stop
I RAPARENT W !!?3,$C(7),"Only Detailed, Series, and Broad procedures can be selected !",! K RAORDS Q
Q:RAX="P" ;entry is only a single P, so don't flag
S RADPARFL=1 ; flag
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAORDS 8219 printed Apr 09, 2024@21:40:09 Page 2
RAORDS ;HISC/CAH,DAD AISC/RMO-Select Patient's Requests ; Nov 08, 2022@12:41:56
+1 ;;5.0;Radiology/Nuclear Medicine;**15,21,132,174,196**;Mar 16, 1998;Build 1
+2 ; Supported IA #1120 reference to EN6^GMRVUTL 5-132
+3 ;p174 changed all references to *7 to $C(7)
+4 ;
+5 if '$DATA(RADFN)
QUIT
DO HOME^%ZIS
KILL ^TMP($JOB,"RAORDS"),RAOUT,RAORDS
+6 KILL ^TMP($JOB,"PRO-ORD"),^TMP($JOB,"PRO-REG")
+7 ; ^tmp($j,"pro-ord",proc-ien,order-ien) -- outstanding orders
+8 ; ^tmp($j,"pro-reg",proc-ien,order-ien) -- actually regist'd procs
+9 SET ^TMP($JOB,"RAORDS","Unknown")=""
+10 SET (RACNT,RASEQ,RAPARENT)=0
SET RAOSTSYM="dc^c^h^^p^^^s"
+11 KILL RAOSTSNM
SET X(1)=^DD(75.1,5,0)
FOR I=1:1
SET RAOSTS=$PIECE(RAOVSTS,";",I)
if RAOSTS=""
QUIT
SET X=$PIECE($PIECE(X(1),RAOSTS_":",2),";")
SET RAOSTSNM=$SELECT('$DATA(RAOSTSNM):X,1:RAOSTSNM_", "_X)
+12 FOR RALP=1:1
SET RAOSTS=$PIECE(RAOVSTS,";",RALP)
if RAOSTS=""
QUIT
FOR RAOIFN=0:0
SET RAOIFN=$ORDER(^RAO(75.1,"AS",RADFN,RAOSTS,RAOIFN))
if 'RAOIFN
QUIT
IF $DATA(^RAO(75.1,RAOIFN,0))
SET RAORD0=^(0)
DO SETUTL
+13 IF '$DATA(^TMP($JOB,"RAORDS"))!('RACNT)
WRITE !!?5,"No requests available to select for this patient.",!
GOTO Q
+14 FOR RAOURG=0:0
SET RAOURG=$ORDER(^TMP($JOB,"RAORDS",RAOURG))
if 'RAOURG!($DATA(RAOSEL))
QUIT
FOR RAODTI=0:0
SET RAODTI=$ORDER(^TMP($JOB,"RAORDS",RAOURG,RAODTI))
if 'RAODTI!($DATA(RAOSEL))
QUIT
DO CHKORD
+15 ;
Q KILL ^TMP($JOB,"RAORDS"),RACNT,RACNT1,RADASH,RADUP,RAERR,RAI,RALCTN,RALOC
+1 KILL RALP,RANUM,RAOASTS,RAODTE,RAODTI,RAOFNS,RAOIFN,RAOIFNS,RAORD0,RAOSEL
+2 KILL RAOSTS,RAOSTSNM,RAOSTSYM,RAOURG,RAOVSTS,RAPHY,RAPAR,RAPRC,RAREQ
+3 KILL RASEL,RASEQ,RAX
+4 QUIT
+5 ;
SETUTL ; Check if option is to be screened. If yes, apply the screen.
+1 ; Parent without descendents
IF $PIECE($GET(^RAMIS(71,+$PIECE(RAORD0,U,2),0)),U,6)="P"
IF $ORDER(^RAMIS(71,+$PIECE(RAORD0,U,2),4,0))'>0
QUIT
+2 ; Cannot choose parent in add exams option
IF $DATA(RAVSTFLG)#2
IF $PIECE($GET(^RAMIS(71,+$PIECE(RAORD0,U,2),0)),U,6)="P"
QUIT
+3 IF $DATA(RASCREEN)
Begin DoDot:1
+4 SET RALCTN=+$PIECE(RAORD0,"^",20)
+5 if 'RALCTN
SET RALCTN="Unknown"
if RALCTN="Unknown"
QUIT
+6 SET RALCTN=$SELECT($DATA(^RA(79.1,RALCTN,0)):+$PIECE(^(0),"^"),1:"Unknown")
+7 if RALCTN="Unknown"
QUIT
+8 SET RALCTN=$SELECT($DATA(^SC(RALCTN,0)):$PIECE(^(0),"^"),1:"Unknown")
+9 QUIT
End DoDot:1
if '$DATA(^TMP($JOB,"RA L-TYPE",RALCTN))
QUIT
+10 ;p196 - referral opt & already referred (field #201)
+11 ;RA196 don't list orders already referred.
IF ($DATA(RAOPT("CCR")))&($DATA(^RAO(75.1,"AC",1,RADFN,RAOIFN)))
QUIT
+12 SET RACNT=RACNT+1
SET ^TMP($JOB,"RAORDS",$SELECT('$PIECE(RAORD0,"^",6):9,1:$PIECE(RAORD0,"^",6)),9999999.9999-$SELECT($PIECE(RAORD0,"^",21):$PIECE(RAORD0,"^",21),1:$PIECE(RAORD0,"^",16)),RAOIFN,RACNT)=RAORD0
+13 ; store order's indiv procedures
+14 IF $PIECE($GET(^RAMIS(71,+$PIECE(RAORD0,U,2),0)),U,6)'="P"
SET ^TMP($JOB,"PRO-ORD",$SELECT($PIECE(RAORD0,U,2):$PIECE(RAORD0,U,2),1:0),RAOIFN)=""
QUIT
+15 ; for parent orders, must store each descendant's proc ien
+16 SET RA6=+$PIECE(RAORD0,U,2)
SET RA7=0
+17 FOR
SET RA7=$ORDER(^RAMIS(71,RA6,4,RA7))
if 'RA7
QUIT
SET ^TMP($JOB,"PRO-ORD",+$PIECE($GET(^(RA7,0)),U),RAOIFN)="DESC"
+18 QUIT
+19 ;
CHKORD FOR RAOIFN=0:0
SET RAOIFN=$ORDER(^TMP($JOB,"RAORDS",RAOURG,RAODTI,RAOIFN))
if 'RAOIFN!($DATA(RAOSEL))
QUIT
FOR RACNT1=0:0
SET RACNT1=$ORDER(^TMP($JOB,"RAORDS",RAOURG,RAODTI,RAOIFN,RACNT1))
if RACNT1'>0!($DATA(RAOSEL))
QUIT
SET RAORD0=^(RACNT1)
DO PRTORD
+1 QUIT
+2 ;
PRTORD if '(RASEQ#8)
DO HD
if $DATA(RAOSEL)
QUIT
SET RASEQ=RASEQ+1
SET RAOIFNS(RASEQ)=RAOIFN
SET RAPRC=$SELECT($DATA(^RAMIS(71,+$PIECE(RAORD0,"^",2),0)):$PIECE(^(0),"^"),1:"Unknown")
SET RAODTE=9999999.9999-RAODTI
+1 SET RAPHY=$SELECT($DATA(^VA(200,+$PIECE(RAORD0,"^",14),0)):$PIECE(^(0),"^"),1:"Unknown")
SET RALOC=$SELECT($DATA(^SC(+$PIECE(RAORD0,"^",22),0)):$PIECE(^(0),"^"),1:"Unknown")
+2 ;parent proc and single rpt
NEW RA6
SET RA6=$SELECT($PIECE($GET(^RAMIS(71,+$PIECE(RAORD0,U,2),0)),U,6)="P"&($PIECE($GET(^(0)),U,18)="Y"):"+",1:"")
+3 ;//p174 begin //
+4 ; ;protection if called from RAORD2 or RAREG1 & covered if RAFLGA = 1
IF $GET(RAFLGA)'=2
Begin DoDot:1
+5 WRITE !,$JUSTIFY(RASEQ,2),?4,$PIECE(RAOSTSYM,"^",+$PIECE(RAORD0,"^",5)),?8,$EXTRACT($PIECE($PIECE(^DD(75.1,6,0),RAOURG_":",2),";"),1,7),?16,RA6
+6 WRITE ?17,$EXTRACT(RAPRC,1,25),?44,$EXTRACT(RAODTE,4,5)_"/"_$EXTRACT(RAODTE,6,7)_"/"_(1700+$EXTRACT(RAODTE,1,3)),?56,$EXTRACT(RAPHY,1,11),?69,$EXTRACT(RALOC,1,11)
+7 WRITE !?17,"(",$SELECT($PIECE(RAORD0,U,20)="":"UNKNOWN",1:$EXTRACT($PIECE($GET(^SC(+$GET(^RA(79.1,+$PIECE(RAORD0,U,20),0)),0)),U),1,23)),")"
+8 QUIT
End DoDot:1
+9 ;schedule a request display P174
IF '$TEST
Begin DoDot:1
+10 WRITE !,$JUSTIFY(RASEQ,2),?4,$PIECE(RAOSTSYM,"^",+$PIECE(RAORD0,"^",5)),?8,$EXTRACT($PIECE($PIECE(^DD(75.1,6,0),RAOURG_":",2),";"),1,7),?16,RA6
+11 WRITE ?17,$EXTRACT(RAPRC,1,20),?40,$EXTRACT(RAODTE,4,5)_"/"_$EXTRACT(RAODTE,6,7)_"/"_(1700+$EXTRACT(RAODTE,1,3)),?52,$EXTRACT($TRANSLATE($$FMTE^XLFDT($PIECE(RAORD0,U,23),"5F")," ",0),1,10)
+12 WRITE ?65,$EXTRACT(RAPHY,1,11)
+13 WRITE !?17,"(",$SELECT($PIECE(RAORD0,U,20)="":"UNKNOWN",1:$EXTRACT($PIECE($GET(^SC(+$GET(^RA(79.1,+$PIECE(RAORD0,U,20),0)),0)),U),1,23)),")"
+14 WRITE ?65,"("_$EXTRACT(RALOC,1,11)_")"
+15 QUIT
End DoDot:1
+16 ;//p174 end //
+17 if RACNT=RASEQ
DO ASKSEL
+18 QUIT
+19 ;
HD if RASEQ
DO ASKSEL
if $DATA(RAOSEL)
QUIT
WRITE @IOF,!?16,"**** Requested Exams for ",$EXTRACT(RANME,1,20)," ****",?65,$JUSTIFY(RACNT,3),?70,"Requests"
+1 ;RTW Add height and weight *** BEGIN ***
+2 ;
Begin DoDot:1
+3 NEW RAHDVITL,RAHDX,DFN,GMRVSTR,X,Y
+4 FOR RAHDVITL="HT","WT"
Begin DoDot:2
+5 SET DFN=RADFN
SET GMRVSTR=RAHDVITL
+6 DO EN6^GMRVUTL
SET RAHDX=$GET(X)
+7 WRITE !?2,$EXTRACT(RAHDVITL),"eight : ",$PIECE(RAHDX,U,8)
+8 IF $PIECE(RAHDX,U,8)]""
WRITE $SELECT(RAHDVITL="HT":"""",RAHDVITL="WT":" lbs",1:"")
+9 SET Y=$PIECE(RAHDX,U,1)
IF Y>0
DO D^RAUTL
WRITE " on ",Y
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 ;RTW Add height and weight *** END ***
+13 ;//p174 begin //
+14 ;protection if called from RAORD2 or RAREG1 & covered if RAFLGA = 1
IF $GET(RAFLGA)'=2
Begin DoDot:1
+15 WRITE !?4,"St",?8,"Urgency",?17,"Procedure / (Img. Loc.)",?44,"Desired",?56,"Requester",?69,"Req'g Loc",!?4,"--",?8,"-------",?17,"-------------------------",?44,"----------",?56,"-----------",?69,"-----------"
+16 QUIT
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 WRITE !?4,"St",?8,"Urgency",?17,"Procedure / (I-Loc.)",?40,"Desired",?52,"Scheduled",?65,"Req Phy / (Loc)"
+19 WRITE !?4,"--",?8,"-------",?17,"--------------------",?40,"----------",?52,"----------",?65,"---------------"
+20 QUIT
End DoDot:1
+21 ;//p174 end //
+22 QUIT
+23 ;
ASKSEL KILL RADUP,RAORDS
SET (RAERR,RAI,RANUM)=0
+1 if $DATA(RAOPT("REG"))
WRITE !!,"(Use Pn to replace request 'n' with a Printset procedure.)"
+2 if '$DATA(RAOPT("REG"))
WRITE !
+3 WRITE !,"Select Request(s) 1-",RASEQ,$SELECT($DATA(RAOFNS):" to "_RAOFNS,1:"")," or '^' to Exit: ",$SELECT(RASEQ<RACNT:"Continue",1:"Exit"),"// "
READ X:DTIME
if '$TEST
SET X="^"
SET RAOUT=""
if X["^"
SET RAOSEL=0
if X["^"!(X="")
QUIT
+4 SET RAX=X
IF RAX["?"
WRITE !!?3,"Please select the request(s) you want separated by commas or a range",!?3,"of numbers separated by a dash, or a combination of commas and dashes."
DO HLPSEL
GOTO ASKSEL
PARSE ; detail-to-parent
IF $$UP^XLFSTR(RAX)?1"P".N
DO DPAR
QUIT
+1 SET RAI=RAI+1
SET RAPAR=$PIECE(RAX,",",RAI)
if RAPAR=""
QUIT
IF RAPAR?.N1"-".N
SET RADASH=""
FOR RASEL=$PIECE(RAPAR,"-"):1:$PIECE(RAPAR,"-",2)
DO CHKSEL
if RAERR
QUIT
+2 IF '$DATA(RADASH)
SET RASEL=RAPAR
DO CHKSEL
+3 KILL RADASH
if RAERR
GOTO ASKSEL
GOTO PARSE
+4 ;
CHKSEL IF $DATA(RADASH)
IF +$PIECE(RAPAR,"-",2)<+$PIECE(RAPAR,"-")
SET RAERR=1
QUIT
+1 IF RASEL'?.N
WRITE !?3,$CHAR(7),"Item ",RASEL," is not a valid selection."
SET RAERR=1
QUIT
+2 IF '$DATA(RAOIFNS(RASEL))
WRITE !?3,$CHAR(7),"Item ",RASEL," is not a valid selection."
SET RAERR=1
QUIT
+3 IF $DATA(RADUP(RASEL))
WRITE !?3,$CHAR(7),"Item ",RASEL," was already selected."
SET RAERR=1
QUIT
+4 IF $DATA(^RAO(75.1,+(RAOIFNS(RASEL)),0))
IF RAOVSTS'[$PIECE(^(0),"^",5)
WRITE !?3,$CHAR(7),"Item ",RASEL," does not have a valid status for this option.",!?3,"Valid statuses are ",RAOSTSNM,"."
SET RAERR=1
QUIT
+5 ; Two parents chosen
IF RAPARENT
IF $PIECE($GET(^RAMIS(71,+$PIECE($GET(^RAO(75.1,+RAOIFNS(RASEL),0)),U,2),0)),U,6)="P"
IF ('$DATA(RAOPT("ORDERPRINTPAT")))
Begin DoDot:1
+6 ; check NOT valid during 'Print Selected Requests by Patient' option!
+7 WRITE !!?3,$CHAR(7),"Only one parent type procedure may be chosen at a time."
+8 WRITE !?3,"(You have already chosen ",$PIECE($GET(^RAMIS(71,RAPARENT,0)),U),".)"
+9 QUIT
End DoDot:1
SET RAERR=1
SET RAPARENT=0
QUIT
+10 SET RANUM=RANUM+1
SET RADUP(RASEL)=""
SET RAORDS(RANUM)=RAOIFNS(RASEL)
SET RAOSEL=RANUM
+11 IF $PIECE($GET(^RAMIS(71,+$PIECE($GET(^RAO(75.1,+RAOIFNS(RASEL),0)),U,2),0)),U,6)="P"
Begin DoDot:1
+12 SET RAPARENT=+$PIECE($GET(^RAO(75.1,+RAOIFNS(RASEL),0)),U,2)
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
HLPSEL IF $DATA(RAOSTSNM)
WRITE !!?3,"The request(s) must have one of the following statuses",$SELECT($DATA(RAOFNS):" to "_RAOFNS,1:""),":",!?6,RAOSTSNM
+1 IF RAX["??"
WRITE !!?3,"Status Symbols: 'dc' - discontinued 'c' - complete 'h' - on hold",!?20,"'p' - pending ' ' - active 's' - scheduled"
+2 QUIT
DPAR ; convert detail proc to parent
+1 ; remove leading 'P'
SET RASEL=$EXTRACT(RAX,2,$LENGTH(RAX))
+2 ;set to 1 char so chksel will reject it
if RASEL=""
SET RASEL="P"
+3 DO CHKSEL
+4 ; if order's proc is a parent, then --
+5 ; 1-kill raords to skip exam^rareg1
+6 ; 2-don't kill raosel so chkord loop would stop
+7 IF RAPARENT
WRITE !!?3,$CHAR(7),"Only Detailed, Series, and Broad procedures can be selected !",!
KILL RAORDS
QUIT
+8 ;entry is only a single P, so don't flag
if RAX="P"
QUIT
+9 ; flag
SET RADPARFL=1
+10 QUIT
+11 ;
