PSJCLOR5 ;BIR/JCH - INPATIENT MEDICATIONS UTILITIES FOR CLINIC ORDERS ;25 SEP 97 / 7:43 AM
;;5.0;INPATIENT MEDICATIONS;**275,315**;16 DEC 97;Build 73
;;Per VHA Directive 2004-038, this routine should not be modified.
; Reference to ^PS(55 is supported by DBIA# 2191
; Reference to ^PS(50.7 is supported by DBIA 2180.
; Reference to ^PS(51.2 is supported by DBIA 2178.
; Reference to ^PS(52.6 is supported by DBIA 1231.
; Reference to ^PS(52.7 is supported by DBIA 2173.
;
DSPORD(PSGP,TMPORDER,PSJORDAR) ; Display order summary
N NDP2,PSJOINM,TMPSTOP,ND0,ND2,ND2P1,NDP1,TMPSTARE,TMPSOL1,PSJBLANK S ND0=$S(TMPORDER["U":$G(^PS(55,PSGP,5,+TMPORDER,0)),TMPORDER["P":$G(^PS(53.1,+TMPORDER,0)),TMPORDER["V":$G(^PS(55,PSGP,"IV",+TMPORDER,0)),1:"") ;*315
S ND2=$S(TMPORDER["U":$G(^PS(55,PSGP,5,+TMPORDER,2)),TMPORDER["P":$G(^PS(53.1,+TMPORDER,2)),TMPORDER["V":$G(^PS(55,PSGP,"IV",+TMPORDER,2)),1:""),TMPSTOP=$P(ND2,"^",4)
S NDP2=$S(TMPORDER["U":$G(^PS(55,PSGP,5,+TMPORDER,.2)),TMPORDER["P":$G(^PS(53.1,+TMPORDER,.2)),TMPORDER["V":$G(^PS(55,PSGP,"IV",+TMPORDER,.2)),1:"")
S ND2P1=$S(TMPORDER["U":$G(^PS(55,PSGP,5,+TMPORDER,2.1)),TMPORDER["P":$G(^PS(53.1,+TMPORDER,2.1)),1:"") ;*315 DRP
I TMPORDER["V" S TMPSOL1=$G(^PS(55,PSGP,"IV",+TMPORDER,"SOL",1,0)),TMPSTOP=$P(ND0,"^",3)
S TMPSTARE=$S(TMPORDER["P"!(TMPORDER["U"):$$FMTE^XLFDT($P(ND2,"^",2),2),TMPORDER["V":$$FMTE^XLFDT($P(ND0,"^",2),2),1:"") I TMPSTARE D
.S TMPSTARE=$P(TMPSTARE,"@"),TMPSTOP=$P($$FMTE^XLFDT(TMPSTOP,2),"@") F TMPDT="TMPSTARE","TMPSTOP" N PSJPCNT,PSJPCV S PSJPCNT=0 F PSJPCNT=1:1 S PSJPCV=$P(@(TMPDT),"/",PSJPCNT) Q:(PSJPCV="") I PSJPCV,(PSJPCV<10) D
..S $P(@(TMPDT),"/",PSJPCNT)=0_+PSJPCV
.S TMPSTARE=TMPSTARE_" "_TMPSTOP
I '$G(PSJORDAR) D
.I TMPORDER'["V" S PSJOINM=$P($G(^PS(50.7,+$P(NDP2,"^"),0)),"^") W !?5,$S(PSJOINM]"":PSJOINM,1:"DRUG NAME NOT FOUND") W ?50,TMPSTARE D
..W !?8," Give: ",$P(NDP2,"^",2)," ",$P($G(^PS(51.2,+$P(ND0,"^",3),0)),"^",3)," ",$P(ND2,"^")
.I TMPORDER["V" D
..N PSIVACNT,PSJINDNT,AD,ADINT,ADEXT S AD=0 F PSIVACNT=1:1 S AD=$O(^PS(55,PSGP,"IV",+TMPORDER,"AD",AD)) Q:AD="" S ADINT=$G(^(AD,0)),AD(0)=$G(AD(0))+1 I ADINT W !?5,$P($G(^PS(52.6,+ADINT,0)),"^") I (PSIVACNT=1) W ?50,TMPSTARE
..S PSJINDNT=$S($G(ADINT):8,1:4)
..W !?PSJINDNT W " in ",$P($G(^PS(52.7,+$G(TMPSOL1),0)),"^")," ",$P(TMPSOL1,"^",2)," ",$P(ND0,"^",8),?50,$S('$G(ADINT):TMPSTARE,1:"")
I $G(PSJORDAR) S $P(PSJBLANK," ",75)=" " D
.I TMPORDER'["V" S PSJORDAR(1)=" "_$P($G(^PS(50.7,+$P(NDP2,"^"),0)),"^") D
..S PSJORDAR(1)=PSJORDAR(1)_$E(PSJBLANK,1,49-$L(PSJORDAR(1)))_TMPSTARE
..S PSJORDAR(2)=$E(PSJBLANK,1,8)_"Give: "_$P(NDP2,"^",2)_" "_$P($G(^PS(51.2,+$P(ND0,"^",3),0)),"^",3)_" "_$P(ND2,"^")
.I TMPORDER["V" N AD,ADINT,ADEXT,PSJINDNT,PAD1,PAD2 S $P(PAD1," ",75)=" " D
..N II S II=1,AD=0 F S AD=$O(^PS(55,PSGP,"IV",+TMPORDER,"AD",AD)) Q:AD="" D
...S ADINT=$G(^(AD,0)) I ADINT S ADEXT=$P($G(^PS(52.6,+ADINT,0)),"^") S AD(0)=$G(AD(0))+1,PSJORDAR(AD(0))=" "_ADEXT S PSJORDAR(AD(0))=PSJORDAR(AD(0))_$E(PSJBLANK,1,49-$L(PSJORDAR(AD(0))))_$S(II=1:TMPSTARE,1:""),II=II+1
..S PSJINDNT=$S($G(ADINT):8,1:4)
..S AD(0)=$G(AD(0))+1 S PSJORDAR(AD(0))=$E(PSJBLANK,1,PSJINDNT)_" in "_$P($G(^PS(52.7,+$G(TMPSOL1),0)),"^")_" "_$P(TMPSOL1,"^",2)_" "_$P(ND0,"^",8) D
...S PSJORDAR(AD(0))=$E(PSJORDAR(AD(0)),1,49) S PAD2=49-$L(PSJORDAR(AD(0))),PAD2=$E(PAD1,1,PAD2) S PSJORDAR(AD(0))=PSJORDAR(AD(0))_$S('$G(ADINT):PAD2_TMPSTARE,1:"")
Q
ORDCHK ; Check for conflicts among selected orders
N PSJHOLD,PSJSELOR,PSJREVDN,PSJOROR,PSJOROR2,PSJCOMFL,TMPSELX,TMPSELX2,TMPSELCO,TMPSELCO1,TMPSELCO2,PSJONCAL,PSJMRR
S PSJSELOR=$S($G(TMPSELOR):TMPSELOR,1:$P($G(Y(1)),"=",2)) Q:'PSJSELOR I $E(PSJSELOR,$L(PSJSELOR))'="," S PSJSELOR=PSJSELOR_","
D NOW^%DTC S PSGDT=+$E(%,1,12),PSJCOMFL="",PSJONCAL=""
S TMPCNT=0,TMPSEL=0,PSJTMPON="" F TMPCNT=1:1:($L(PSJSELOR,",")) Q:'TMPCNT D
.S TMPSEL=$P(PSJSELOR,",",TMPCNT) Q:'TMPSEL S PSJTMPON=$G(^TMP("PSJON",$J,TMPSEL)) Q:'PSJTMPON
.N STAT S STAT=$S(PSJTMPON["U":$P($G(^PS(55,PSGP,5,+PSJTMPON,0)),"^",9),PSJTMPON["V":$P($G(^PS(55,PSGP,"IV",+PSJTMPON,0)),"^",17),1:"")
.I STAT="H" S PSJHOLD(PSJTMPON)=TMPSEL
.;*315 Begin changes
.I PSJTMPON["U",$P($G(^PS(55,PSGP,5,+PSJTMPON,2.1)),U,4)>1 S PSJMRR(TMPSEL)=PSJTMPON
.Q
S TMPSELCO=PSJSELOR
;
I $D(PSJMRR)>1 D FULL^VALM1 D
.N PSJMRRCNT,PSJDASH1,TMPARRAY S $P(PSJDASH1,"-",75)="-"
.W !!,"The following orders you have selected may have a specified removal event and",!," cannot be edited via this option."
.W !,"Use the Inpatient Order entry option to modify these orders"
.W !!,"Orders for Medications that require removal:",?45,"Current Start / Stop Dates",!,PSJDASH1
.S TMPSEL=0 ;Display disallowed orders
.F PSJMRRCNT=1:1 S TMPSEL=$O(PSJMRR(TMPSEL)) Q:'TMPSEL D
..I '(PSJMRRCNT#8) N DIR W ! D CONT^PSJOE0,CLEAR^VALM1,FULL^VALM1 W !!,"Orders for Medications that require removal (CONTINUED):",?45,"Current Start / Stop Dates",!,PSJDASH1
..D DSPORD^PSJCLOR2(PSGP,PSJMRR(TMPSEL))
..Q ;Build selection array
.F TMPCNT=1:1:$L(TMPSELCO,",") D
..S TMPARRAY(TMPCNT)=$P(TMPSELCO,",",TMPCNT)
..S TMPSEL=0
..F S TMPSEL=$O(PSJMRR(TMPSEL)) Q:'TMPSEL D
...I $G(TMPARRAY(TMPCNT))=TMPSEL K TMPARRAY(TMPCNT) ; If the selection is in disallowed array kill it.
...Q
..Q
.S TMPSEL="" K TMPSELCO
.S TMPSEL=$NA(TMPARRAY) F TMPCNT=1:1 S TMPSEL=$Q(@TMPSEL) Q:TMPSEL="" S $P(TMPSELCO,",",TMPCNT)=@TMPSEL ; rebuild selection string
.N DIR W ! D CONT^PSJOE0 W !
.Q
;
S (PSJSELOR,TMPSELOR)=TMPSELCO
;end *315 changes
;
I $D(PSJHOLD)>1 D FULL^VALM1 D
.N PSJDASH1 S $P(PSJDASH1,"-",75)="-"
.W !!," ON HOLD orders cannot be edited - no changes will be applied",!," to any of the following ON HOLD orders:"
.W !,"ON HOLD orders:",?45,"Current Start / Stop Dates",!,PSJDASH1
.N PSJOHCT S PSJOROR2="" F PSJOHCT=1:1 S PSJOROR2=$O(PSJHOLD(PSJOROR2)) Q:'PSJOROR2 D
..I '(PSJOHCT#8) N DIR W ! D CONT^PSJOE0,CLEAR^VALM1,FULL^VALM1 W !!,"ON HOLD orders (CONTINUED):",?45,"Current Start / Stop Dates",!,PSJDASH1
..D DSPORD^PSJCLOR2(PSGP,PSJOROR2)
..I PSJHOLD(PSJOROR2)=$P(TMPSELCO,",") S TMPSELCO=$P(TMPSELCO,PSJHOLD(PSJOROR2)_",",2) Q
..S TMPSELCO1=$P(TMPSELCO,","_PSJHOLD(PSJOROR2)_","),TMPSELCO2=$P(TMPSELCO,","_PSJHOLD(PSJOROR2)_",",2) S TMPSELCO=TMPSELCO1_$S(TMPSELCO2]"":","_TMPSELCO2,1:"")
.N DIR W ! D CONT^PSJOE0 W !
S (PSJSELOR,TMPSELOR)=TMPSELCO
S TMPCNT=0,TMPSEL=0,PSJTMPON="" F TMPCNT=1:1:($L(PSJSELOR,",")) Q:'TMPCNT D
.S TMPSEL=$P(PSJSELOR,",",TMPCNT) Q:'TMPSEL S PSJTMPON=$G(^TMP("PSJON",$J,TMPSEL)) Q:'PSJTMPON
.N STAT S STAT=$S(PSJTMPON["U":$P($G(^PS(55,PSGP,5,+PSJTMPON,0)),"^",9),PSJTMPON["V":$P($G(^PS(55,PSGP,"IV",+PSJTMPON,0)),"^",17),1:"")
.I STAT="O" S PSJONCAL(PSJTMPON)=TMPSEL
S TMPSELCO=PSJSELOR
I $D(PSJONCAL)>1 D FULL^VALM1 D
.N PSJOCCNT,PSJDASH1 S $P(PSJDASH1,"-",75)="-"
.W !!," Orders with ON CALL Status cannot be edited - no changes will be applied",!," to any of the following orders with ON CALL status:"
.W !,"ON CALL Status orders:",?45,"Current Start / Stop Dates",!,PSJDASH1
.S PSJOROR2="" F PSJOCCNT=1:1 S PSJOROR2=$O(PSJONCAL(PSJOROR2)) Q:'PSJOROR2 D
..I '(PSJOCCNT#8) N DIR W ! D CONT^PSJOE0,CLEAR^VALM1,FULL^VALM1 W !!,"ON CALL Status orders (CONTINUED):",?45,"Current Start / Stop Dates",!,PSJDASH1
..D DSPORD^PSJCLOR2(PSGP,PSJOROR2)
..I PSJONCAL(PSJOROR2)=$P(TMPSELCO,",") S TMPSELCO=$P(TMPSELCO,PSJONCAL(PSJOROR2)_",",2) Q
..S TMPSELCO1=$P(TMPSELCO,","_PSJONCAL(PSJOROR2)_","),TMPSELCO2=$P(TMPSELCO,","_PSJONCAL(PSJOROR2)_",",2) S TMPSELCO=TMPSELCO1_$S(TMPSELCO2]"":","_TMPSELCO2,1:"")
.N DIR W ! D CONT^PSJOE0 W !
S (PSJSELOR,TMPSELOR)=TMPSELCO
S TMPCNT=0,TMPSEL=0,PSJTMPON="" F TMPCNT=1:1:($L(PSJSELOR,",")) Q:'TMPCNT D
.S TMPSEL=$P(PSJSELOR,",",TMPCNT) Q:'TMPSEL S PSJTMPON=$G(^TMP("PSJON",$J,TMPSEL)) Q:'PSJTMPON
.I (PSJTMPON=+PSJTMPON),$D(^PS(53.1,"ACX",PSJTMPON)) S PSJCOMFL="P",PSJOROR="" F S PSJOROR=$O(^PS(53.1,"ACX",PSJTMPON,PSJOROR)) Q:'PSJOROR S PSJCOMFL(PSJOROR_"P")=TMPSEL
.I PSJCOMFL="" S PSJOROR=$S(PSJTMPON["U":$P($G(^PS(55,PSGP,5,+PSJTMPON,.2)),"^",8),PSJTMPON["V":$P($G(^PS(55,PSGP,"IV",+PSJTMPON,.2)),"^",8),1:"") Q:'PSJOROR D
..S PSJCOMFL(PSJTMPON)=TMPSEL
S TMPSELCO=PSJSELOR
I $D(PSJCOMFL)>1 D FULL^VALM1 D
.N PSJDASH1 S $P(PSJDASH1,"-",75)="-"
.W !!," Complex Orders cannot be edited - no changes will be applied",!," to any of the following Complex order components:"
.W !,"Complex Component (Child) Orders:",?45,"Current Start / Stop Dates",!,PSJDASH1
.N PSJCOMCT S PSJOROR2="" F PSJCOMCT=1:1 S PSJOROR2=$O(PSJCOMFL(PSJOROR2)) Q:'PSJOROR2 D
..I '(PSJCOMCT#8) N DIR W ! D CONT^PSJOE0,CLEAR^VALM1,FULL^VALM1 W !!,"Complex orders (CONTINUED):",?45,"Current Start / Stop Dates",!,PSJDASH1
..D DSPORD^PSJCLOR2(PSGP,PSJOROR2)
..I PSJCOMFL(PSJOROR2)=$P(TMPSELCO,",") S TMPSELCO=$P(TMPSELCO,PSJCOMFL(PSJOROR2)_",",2) Q
..S TMPSELCO1=$P(TMPSELCO,","_PSJCOMFL(PSJOROR2)_","),TMPSELCO2=$P(TMPSELCO,","_PSJCOMFL(PSJOROR2)_",",2) S TMPSELCO=TMPSELCO1_$S(TMPSELCO2]"":","_TMPSELCO2,1:"")
.W ! N DIR D CONT^PSJOE0 W !
S (PSJSELOR,TMPSELOR)=TMPSELCO
N TMPNEWSD,TMPSEL,TMPCLN,TMPCLNAR,PSJSTPDT,PSJTMPON,TMPCNT S PSJSTPDT="" S PSJQMSG=0,PSJABORT=0
I ('$G(PSGOEAV)&(+$G(PSJSYSU)=3))!(+$G(PSJSYSU)'=3) S TMPCNT=0,TMPSEL=0,PSJTMPON="" F TMPCNT=1:1:($L(PSJSELOR,",")) Q:'TMPCNT!$G(PSJREVFY)!$G(PSJREVDN) D
.S TMPSEL=$P(PSJSELOR,",",TMPCNT) Q:'TMPSEL S PSJTMPON=$G(^TMP("PSJON",$J,TMPSEL)) Q:'PSJTMPON
.I PSJTMPON["V"!(PSJTMPON["U") S PSJREVFY=$S(+PSJSYSU=3:$$PSJREVFY^PSJCLOR1(),1:$$SURE^PSJCLOR1()),PSJREVDN=1
I $G(DUOUT)!($G(PSJREVFY)<0) S PSJABORT=2 Q
;
S TMPCNT=0,TMPSEL=0,PSJTMPON="" F TMPCNT=1:1:($L(PSJSELOR,",")) Q:'TMPCNT S TMPSEL=$P(PSJSELOR,",",TMPCNT) Q:'TMPSEL S PSJTMPON=$G(^TMP("PSJON",$J,TMPSEL)) Q:'PSJTMPON D
.N ND0,ND2,NDP1 S ND0=$S(PSJTMPON["U":$G(^PS(55,PSGP,5,+PSJTMPON,0)),PSJTMPON["P":$G(^PS(53.1,+PSJTMPON,0)),PSJTMPON["V":$G(^PS(55,PSGP,"IV",+PSJTMPON,0)),1:"")
.S ND2=$S(PSJTMPON["U":$G(^PS(55,PSGP,5,+PSJTMPON,2)),PSJTMPON["P":$G(^PS(53.1,+PSJTMPON,2)),PSJTMPON["V":$G(^PS(55,PSGP,"IV",+PSJTMPON,2)),1:"")
.S ND2P1=$S(PSJTMPON["U":$G(^PS(55,PSGP,5,+PSJTMPON,2.1)),PSJTMPON["P":$G(^PS(53.1,+PSJTMPON,2.1)),1:"") ;*315
.S TMPSTR=$S(PSJTMPON["P"!(PSJTMPON["U"):$P(ND2,"^",2),PSJTMPON["V":$P(ND0,"^",2),1:"") S TMPSTR($P(TMPSTR,"."))=""
.S TMPCLN=$S(PSJTMPON["P":+$G(^PS(53.1,+PSJTMPON,"DSS")),PSJTMPON["U":+$G(^PS(55,+$G(PSGP),5,+PSJTMPON,8)),PSJTMPON["V":+$G(^PS(55,$G(PSGP),"IV",+PSJTMPON,"DSS")),1:"")
.Q:'TMPCLN I $O(TMPCLNAR("")),$O(TMPCLNAR(""))'=TMPCLN S PSJABORT=1
.S TMPCLNAR(+TMPCLN)=""
S TMPSTR="" F S TMPSTR=$O(TMPSTR(TMPSTR)) Q:'TMPSTR S TMPSTR(0)=$G(TMPSTR(0))+1
I $G(PSJABORT)!($G(TMPSTR(0))>1) D
.K DIR S DIR("A",1)=" You have selected orders"_$S($G(PSJABORT):" from different clinics",1:" with different Start Date/Times")_" "
.I $G(PSJABORT)&($G(TMPSTR(0))>1) S DIR("A",2)=" and with different Start Date/Times."
.S DIR("A",3)="",DIR("A",4)=""
.W ! N X,Y S DIR("A")="Do you want to continue",DIR(0)="Y" D ^DIR S PSJABORT=$S(Y>0:1,1:2)
Q
;
NEWCLN ; Clean up Order variables
K PSGNEDFD,PSGOEE,PSGOEEWF,PSGOORD,PSGPD,PSGPDN,PSGPDRGN,PSGRDTX,PSGS0Y,PSJCOM,PSJL,PSJNOO,PSJQMSG
K PSJTMPON,VALMBCK,VALMCNT,VALMQUIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJCLOR5 11317 printed Oct 16, 2024@18:07:14 Page 2
PSJCLOR5 ;BIR/JCH - INPATIENT MEDICATIONS UTILITIES FOR CLINIC ORDERS ;25 SEP 97 / 7:43 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**275,315**;16 DEC 97;Build 73
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Reference to ^PS(55 is supported by DBIA# 2191
+4 ; Reference to ^PS(50.7 is supported by DBIA 2180.
+5 ; Reference to ^PS(51.2 is supported by DBIA 2178.
+6 ; Reference to ^PS(52.6 is supported by DBIA 1231.
+7 ; Reference to ^PS(52.7 is supported by DBIA 2173.
+8 ;
DSPORD(PSGP,TMPORDER,PSJORDAR) ; Display order summary
+1 ;*315
NEW NDP2,PSJOINM,TMPSTOP,ND0,ND2,ND2P1,NDP1,TMPSTARE,TMPSOL1,PSJBLANK
SET ND0=$SELECT(TMPORDER["U":$GET(^PS(55,PSGP,5,+TMPORDER,0)),TMPORDER["P":$GET(^PS(53.1,+TMPORDER,0)),TMPORDER["V":$GET(^PS(55,PSGP,"IV",+TMPORDER,0)),1:"")
+2 SET ND2=$SELECT(TMPORDER["U":$GET(^PS(55,PSGP,5,+TMPORDER,2)),TMPORDER["P":$GET(^PS(53.1,+TMPORDER,2)),TMPORDER["V":$GET(^PS(55,PSGP,"IV",+TMPORDER,2)),1:"")
SET TMPSTOP=$PIECE(ND2,"^",4)
+3 SET NDP2=$SELECT(TMPORDER["U":$GET(^PS(55,PSGP,5,+TMPORDER,.2)),TMPORDER["P":$GET(^PS(53.1,+TMPORDER,.2)),TMPORDER["V":$GET(^PS(55,PSGP,"IV",+TMPORDER,.2)),1:"")
+4 ;*315 DRP
SET ND2P1=$SELECT(TMPORDER["U":$GET(^PS(55,PSGP,5,+TMPORDER,2.1)),TMPORDER["P":$GET(^PS(53.1,+TMPORDER,2.1)),1:"")
+5 IF TMPORDER["V"
SET TMPSOL1=$GET(^PS(55,PSGP,"IV",+TMPORDER,"SOL",1,0))
SET TMPSTOP=$PIECE(ND0,"^",3)
+6 SET TMPSTARE=$SELECT(TMPORDER["P"!(TMPORDER["U"):$$FMTE^XLFDT($PIECE(ND2,"^",2),2),TMPORDER["V":$$FMTE^XLFDT($PIECE(ND0,"^",2),2),1:"")
IF TMPSTARE
Begin DoDot:1
+7 SET TMPSTARE=$PIECE(TMPSTARE,"@")
SET TMPSTOP=$PIECE($$FMTE^XLFDT(TMPSTOP,2),"@")
FOR TMPDT="TMPSTARE","TMPSTOP"
NEW PSJPCNT,PSJPCV
SET PSJPCNT=0
FOR PSJPCNT=1:1
SET PSJPCV=$PIECE(@(TMPDT),"/",PSJPCNT)
if (PSJPCV="")
QUIT
IF PSJPCV
IF (PSJPCV<10)
Begin DoDot:2
+8 SET $PIECE(@(TMPDT),"/",PSJPCNT)=0_+PSJPCV
End DoDot:2
+9 SET TMPSTARE=TMPSTARE_" "_TMPSTOP
End DoDot:1
+10 IF '$GET(PSJORDAR)
Begin DoDot:1
+11 IF TMPORDER'["V"
SET PSJOINM=$PIECE($GET(^PS(50.7,+$PIECE(NDP2,"^"),0)),"^")
WRITE !?5,$SELECT(PSJOINM]"":PSJOINM,1:"DRUG NAME NOT FOUND")
WRITE ?50,TMPSTARE
Begin DoDot:2
+12 WRITE !?8," Give: ",$PIECE(NDP2,"^",2)," ",$PIECE($GET(^PS(51.2,+$PIECE(ND0,"^",3),0)),"^",3)," ",$PIECE(ND2,"^")
End DoDot:2
+13 IF TMPORDER["V"
Begin DoDot:2
+14 NEW PSIVACNT,PSJINDNT,AD,ADINT,ADEXT
SET AD=0
FOR PSIVACNT=1:1
SET AD=$ORDER(^PS(55,PSGP,"IV",+TMPORDER,"AD",AD))
if AD=""
QUIT
SET ADINT=$GET(^(AD,0))
SET AD(0)=$GET(AD(0))+1
IF ADINT
WRITE !?5,$PIECE($GET(^PS(52.6,+ADINT,0)),"^")
IF (PSIVACNT=1)
WRITE ?50,TMPSTARE
+15 SET PSJINDNT=$SELECT($GET(ADINT):8,1:4)
+16 WRITE !?PSJINDNT
WRITE " in ",$PIECE($GET(^PS(52.7,+$GET(TMPSOL1),0)),"^")," ",$PIECE(TMPSOL1,"^",2)," ",$PIECE(ND0,"^",8),?50,$SELECT('$GET(ADINT):TMPSTARE,1:"")
End DoDot:2
End DoDot:1
+17 IF $GET(PSJORDAR)
SET $PIECE(PSJBLANK," ",75)=" "
Begin DoDot:1
+18 IF TMPORDER'["V"
SET PSJORDAR(1)=" "_$PIECE($GET(^PS(50.7,+$PIECE(NDP2,"^"),0)),"^")
Begin DoDot:2
+19 SET PSJORDAR(1)=PSJORDAR(1)_$EXTRACT(PSJBLANK,1,49-$LENGTH(PSJORDAR(1)))_TMPSTARE
+20 SET PSJORDAR(2)=$EXTRACT(PSJBLANK,1,8)_"Give: "_$PIECE(NDP2,"^",2)_" "_$PIECE($GET(^PS(51.2,+$PIECE(ND0,"^",3),0)),"^",3)_" "_$PIECE(ND2,"^")
End DoDot:2
+21 IF TMPORDER["V"
NEW AD,ADINT,ADEXT,PSJINDNT,PAD1,PAD2
SET $PIECE(PAD1," ",75)=" "
Begin DoDot:2
+22 NEW II
SET II=1
SET AD=0
FOR
SET AD=$ORDER(^PS(55,PSGP,"IV",+TMPORDER,"AD",AD))
if AD=""
QUIT
Begin DoDot:3
+23 SET ADINT=$GET(^(AD,0))
IF ADINT
SET ADEXT=$PIECE($GET(^PS(52.6,+ADINT,0)),"^")
SET AD(0)=$GET(AD(0))+1
SET PSJORDAR(AD(0))=" "_ADEXT
SET PSJORDAR(AD(0))=PSJORDAR(AD(0))_$EXTRACT(PSJBLANK,1,49-$LENGTH(PSJORDAR(AD(0))))_$SELECT(II=1:TMPSTARE,1:"")
SET II=II+1
End DoDot:3
+24 SET PSJINDNT=$SELECT($GET(ADINT):8,1:4)
+25 SET AD(0)=$GET(AD(0))+1
SET PSJORDAR(AD(0))=$EXTRACT(PSJBLANK,1,PSJINDNT)_" in "_$PIECE($GET(^PS(52.7,+$GET(TMPSOL1),0)),"^")_" "_$PIECE(TMPSOL1,"^",2)_" "_$PIECE(ND0,"^",8)
Begin DoDot:3
+26 SET PSJORDAR(AD(0))=$EXTRACT(PSJORDAR(AD(0)),1,49)
SET PAD2=49-$LENGTH(PSJORDAR(AD(0)))
SET PAD2=$EXTRACT(PAD1,1,PAD2)
SET PSJORDAR(AD(0))=PSJORDAR(AD(0))_$SELECT('$GET(ADINT):PAD2_TMPSTARE,1:"")
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
ORDCHK ; Check for conflicts among selected orders
+1 NEW PSJHOLD,PSJSELOR,PSJREVDN,PSJOROR,PSJOROR2,PSJCOMFL,TMPSELX,TMPSELX2,TMPSELCO,TMPSELCO1,TMPSELCO2,PSJONCAL,PSJMRR
+2 SET PSJSELOR=$SELECT($GET(TMPSELOR):TMPSELOR,1:$PIECE($GET(Y(1)),"=",2))
if 'PSJSELOR
QUIT
IF $EXTRACT(PSJSELOR,$LENGTH(PSJSELOR))'=","
SET PSJSELOR=PSJSELOR_","
+3 DO NOW^%DTC
SET PSGDT=+$EXTRACT(%,1,12)
SET PSJCOMFL=""
SET PSJONCAL=""
+4 SET TMPCNT=0
SET TMPSEL=0
SET PSJTMPON=""
FOR TMPCNT=1:1:($LENGTH(PSJSELOR,","))
if 'TMPCNT
QUIT
Begin DoDot:1
+5 SET TMPSEL=$PIECE(PSJSELOR,",",TMPCNT)
if 'TMPSEL
QUIT
SET PSJTMPON=$GET(^TMP("PSJON",$JOB,TMPSEL))
if 'PSJTMPON
QUIT
+6 NEW STAT
SET STAT=$SELECT(PSJTMPON["U":$PIECE($GET(^PS(55,PSGP,5,+PSJTMPON,0)),"^",9),PSJTMPON["V":$PIECE($GET(^PS(55,PSGP,"IV",+PSJTMPON,0)),"^",17),1:"")
+7 IF STAT="H"
SET PSJHOLD(PSJTMPON)=TMPSEL
+8 ;*315 Begin changes
+9 IF PSJTMPON["U"
IF $PIECE($GET(^PS(55,PSGP,5,+PSJTMPON,2.1)),U,4)>1
SET PSJMRR(TMPSEL)=PSJTMPON
+10 QUIT
End DoDot:1
+11 SET TMPSELCO=PSJSELOR
+12 ;
+13 IF $DATA(PSJMRR)>1
DO FULL^VALM1
Begin DoDot:1
+14 NEW PSJMRRCNT,PSJDASH1,TMPARRAY
SET $PIECE(PSJDASH1,"-",75)="-"
+15 WRITE !!,"The following orders you have selected may have a specified removal event and",!," cannot be edited via this option."
+16 WRITE !,"Use the Inpatient Order entry option to modify these orders"
+17 WRITE !!,"Orders for Medications that require removal:",?45,"Current Start / Stop Dates",!,PSJDASH1
+18 ;Display disallowed orders
SET TMPSEL=0
+19 FOR PSJMRRCNT=1:1
SET TMPSEL=$ORDER(PSJMRR(TMPSEL))
if 'TMPSEL
QUIT
Begin DoDot:2
+20 IF '(PSJMRRCNT#8)
NEW DIR
WRITE !
DO CONT^PSJOE0
DO CLEAR^VALM1
DO FULL^VALM1
WRITE !!,"Orders for Medications that require removal (CONTINUED):",?45,"Current Start / Stop Dates",!,PSJDASH1
+21 DO DSPORD^PSJCLOR2(PSGP,PSJMRR(TMPSEL))
+22 ;Build selection array
QUIT
End DoDot:2
+23 FOR TMPCNT=1:1:$LENGTH(TMPSELCO,",")
Begin DoDot:2
+24 SET TMPARRAY(TMPCNT)=$PIECE(TMPSELCO,",",TMPCNT)
+25 SET TMPSEL=0
+26 FOR
SET TMPSEL=$ORDER(PSJMRR(TMPSEL))
if 'TMPSEL
QUIT
Begin DoDot:3
+27 ; If the selection is in disallowed array kill it.
IF $GET(TMPARRAY(TMPCNT))=TMPSEL
KILL TMPARRAY(TMPCNT)
+28 QUIT
End DoDot:3
+29 QUIT
End DoDot:2
+30 SET TMPSEL=""
KILL TMPSELCO
+31 ; rebuild selection string
SET TMPSEL=$NAME(TMPARRAY)
FOR TMPCNT=1:1
SET TMPSEL=$QUERY(@TMPSEL)
if TMPSEL=""
QUIT
SET $PIECE(TMPSELCO,",",TMPCNT)=@TMPSEL
+32 NEW DIR
WRITE !
DO CONT^PSJOE0
WRITE !
+33 QUIT
End DoDot:1
+34 ;
+35 SET (PSJSELOR,TMPSELOR)=TMPSELCO
+36 ;end *315 changes
+37 ;
+38 IF $DATA(PSJHOLD)>1
DO FULL^VALM1
Begin DoDot:1
+39 NEW PSJDASH1
SET $PIECE(PSJDASH1,"-",75)="-"
+40 WRITE !!," ON HOLD orders cannot be edited - no changes will be applied",!," to any of the following ON HOLD orders:"
+41 WRITE !,"ON HOLD orders:",?45,"Current Start / Stop Dates",!,PSJDASH1
+42 NEW PSJOHCT
SET PSJOROR2=""
FOR PSJOHCT=1:1
SET PSJOROR2=$ORDER(PSJHOLD(PSJOROR2))
if 'PSJOROR2
QUIT
Begin DoDot:2
+43 IF '(PSJOHCT#8)
NEW DIR
WRITE !
DO CONT^PSJOE0
DO CLEAR^VALM1
DO FULL^VALM1
WRITE !!,"ON HOLD orders (CONTINUED):",?45,"Current Start / Stop Dates",!,PSJDASH1
+44 DO DSPORD^PSJCLOR2(PSGP,PSJOROR2)
+45 IF PSJHOLD(PSJOROR2)=$PIECE(TMPSELCO,",")
SET TMPSELCO=$PIECE(TMPSELCO,PSJHOLD(PSJOROR2)_",",2)
QUIT
+46 SET TMPSELCO1=$PIECE(TMPSELCO,","_PSJHOLD(PSJOROR2)_",")
SET TMPSELCO2=$PIECE(TMPSELCO,","_PSJHOLD(PSJOROR2)_",",2)
SET TMPSELCO=TMPSELCO1_$SELECT(TMPSELCO2]"":","_TMPSELCO2,1:"")
End DoDot:2
+47 NEW DIR
WRITE !
DO CONT^PSJOE0
WRITE !
End DoDot:1
+48 SET (PSJSELOR,TMPSELOR)=TMPSELCO
+49 SET TMPCNT=0
SET TMPSEL=0
SET PSJTMPON=""
FOR TMPCNT=1:1:($LENGTH(PSJSELOR,","))
if 'TMPCNT
QUIT
Begin DoDot:1
+50 SET TMPSEL=$PIECE(PSJSELOR,",",TMPCNT)
if 'TMPSEL
QUIT
SET PSJTMPON=$GET(^TMP("PSJON",$JOB,TMPSEL))
if 'PSJTMPON
QUIT
+51 NEW STAT
SET STAT=$SELECT(PSJTMPON["U":$PIECE($GET(^PS(55,PSGP,5,+PSJTMPON,0)),"^",9),PSJTMPON["V":$PIECE($GET(^PS(55,PSGP,"IV",+PSJTMPON,0)),"^",17),1:"")
+52 IF STAT="O"
SET PSJONCAL(PSJTMPON)=TMPSEL
End DoDot:1
+53 SET TMPSELCO=PSJSELOR
+54 IF $DATA(PSJONCAL)>1
DO FULL^VALM1
Begin DoDot:1
+55 NEW PSJOCCNT,PSJDASH1
SET $PIECE(PSJDASH1,"-",75)="-"
+56 WRITE !!," Orders with ON CALL Status cannot be edited - no changes will be applied",!," to any of the following orders with ON CALL status:"
+57 WRITE !,"ON CALL Status orders:",?45,"Current Start / Stop Dates",!,PSJDASH1
+58 SET PSJOROR2=""
FOR PSJOCCNT=1:1
SET PSJOROR2=$ORDER(PSJONCAL(PSJOROR2))
if 'PSJOROR2
QUIT
Begin DoDot:2
+59 IF '(PSJOCCNT#8)
NEW DIR
WRITE !
DO CONT^PSJOE0
DO CLEAR^VALM1
DO FULL^VALM1
WRITE !!,"ON CALL Status orders (CONTINUED):",?45,"Current Start / Stop Dates",!,PSJDASH1
+60 DO DSPORD^PSJCLOR2(PSGP,PSJOROR2)
+61 IF PSJONCAL(PSJOROR2)=$PIECE(TMPSELCO,",")
SET TMPSELCO=$PIECE(TMPSELCO,PSJONCAL(PSJOROR2)_",",2)
QUIT
+62 SET TMPSELCO1=$PIECE(TMPSELCO,","_PSJONCAL(PSJOROR2)_",")
SET TMPSELCO2=$PIECE(TMPSELCO,","_PSJONCAL(PSJOROR2)_",",2)
SET TMPSELCO=TMPSELCO1_$SELECT(TMPSELCO2]"":","_TMPSELCO2,1:"")
End DoDot:2
+63 NEW DIR
WRITE !
DO CONT^PSJOE0
WRITE !
End DoDot:1
+64 SET (PSJSELOR,TMPSELOR)=TMPSELCO
+65 SET TMPCNT=0
SET TMPSEL=0
SET PSJTMPON=""
FOR TMPCNT=1:1:($LENGTH(PSJSELOR,","))
if 'TMPCNT
QUIT
Begin DoDot:1
+66 SET TMPSEL=$PIECE(PSJSELOR,",",TMPCNT)
if 'TMPSEL
QUIT
SET PSJTMPON=$GET(^TMP("PSJON",$JOB,TMPSEL))
if 'PSJTMPON
QUIT
+67 IF (PSJTMPON=+PSJTMPON)
IF $DATA(^PS(53.1,"ACX",PSJTMPON))
SET PSJCOMFL="P"
SET PSJOROR=""
FOR
SET PSJOROR=$ORDER(^PS(53.1,"ACX",PSJTMPON,PSJOROR))
if 'PSJOROR
QUIT
SET PSJCOMFL(PSJOROR_"P")=TMPSEL
+68 IF PSJCOMFL=""
SET PSJOROR=$SELECT(PSJTMPON["U":$PIECE($GET(^PS(55,PSGP,5,+PSJTMPON,.2)),"^",8),PSJTMPON["V":$PIECE($GET(^PS(55,PSGP,"IV",+PSJTMPON,.2)),"^",8),1:"")
if 'PSJOROR
QUIT
Begin DoDot:2
+69 SET PSJCOMFL(PSJTMPON)=TMPSEL
End DoDot:2
End DoDot:1
+70 SET TMPSELCO=PSJSELOR
+71 IF $DATA(PSJCOMFL)>1
DO FULL^VALM1
Begin DoDot:1
+72 NEW PSJDASH1
SET $PIECE(PSJDASH1,"-",75)="-"
+73 WRITE !!," Complex Orders cannot be edited - no changes will be applied",!," to any of the following Complex order components:"
+74 WRITE !,"Complex Component (Child) Orders:",?45,"Current Start / Stop Dates",!,PSJDASH1
+75 NEW PSJCOMCT
SET PSJOROR2=""
FOR PSJCOMCT=1:1
SET PSJOROR2=$ORDER(PSJCOMFL(PSJOROR2))
if 'PSJOROR2
QUIT
Begin DoDot:2
+76 IF '(PSJCOMCT#8)
NEW DIR
WRITE !
DO CONT^PSJOE0
DO CLEAR^VALM1
DO FULL^VALM1
WRITE !!,"Complex orders (CONTINUED):",?45,"Current Start / Stop Dates",!,PSJDASH1
+77 DO DSPORD^PSJCLOR2(PSGP,PSJOROR2)
+78 IF PSJCOMFL(PSJOROR2)=$PIECE(TMPSELCO,",")
SET TMPSELCO=$PIECE(TMPSELCO,PSJCOMFL(PSJOROR2)_",",2)
QUIT
+79 SET TMPSELCO1=$PIECE(TMPSELCO,","_PSJCOMFL(PSJOROR2)_",")
SET TMPSELCO2=$PIECE(TMPSELCO,","_PSJCOMFL(PSJOROR2)_",",2)
SET TMPSELCO=TMPSELCO1_$SELECT(TMPSELCO2]"":","_TMPSELCO2,1:"")
End DoDot:2
+80 WRITE !
NEW DIR
DO CONT^PSJOE0
WRITE !
End DoDot:1
+81 SET (PSJSELOR,TMPSELOR)=TMPSELCO
+82 NEW TMPNEWSD,TMPSEL,TMPCLN,TMPCLNAR,PSJSTPDT,PSJTMPON,TMPCNT
SET PSJSTPDT=""
SET PSJQMSG=0
SET PSJABORT=0
+83 IF ('$GET(PSGOEAV)&(+$GET(PSJSYSU)=3))!(+$GET(PSJSYSU)'=3)
SET TMPCNT=0
SET TMPSEL=0
SET PSJTMPON=""
FOR TMPCNT=1:1:($LENGTH(PSJSELOR,","))
if 'TMPCNT!$GET(PSJREVFY)!$GET(PSJREVDN)
QUIT
Begin DoDot:1
+84 SET TMPSEL=$PIECE(PSJSELOR,",",TMPCNT)
if 'TMPSEL
QUIT
SET PSJTMPON=$GET(^TMP("PSJON",$JOB,TMPSEL))
if 'PSJTMPON
QUIT
+85 IF PSJTMPON["V"!(PSJTMPON["U")
SET PSJREVFY=$SELECT(+PSJSYSU=3:$$PSJREVFY^PSJCLOR1(),1:$$SURE^PSJCLOR1())
SET PSJREVDN=1
End DoDot:1
+86 IF $GET(DUOUT)!($GET(PSJREVFY)<0)
SET PSJABORT=2
QUIT
+87 ;
+88 SET TMPCNT=0
SET TMPSEL=0
SET PSJTMPON=""
FOR TMPCNT=1:1:($LENGTH(PSJSELOR,","))
if 'TMPCNT
QUIT
SET TMPSEL=$PIECE(PSJSELOR,",",TMPCNT)
if 'TMPSEL
QUIT
SET PSJTMPON=$GET(^TMP("PSJON",$JOB,TMPSEL))
if 'PSJTMPON
QUIT
Begin DoDot:1
+89 NEW ND0,ND2,NDP1
SET ND0=$SELECT(PSJTMPON["U":$GET(^PS(55,PSGP,5,+PSJTMPON,0)),PSJTMPON["P":$GET(^PS(53.1,+PSJTMPON,0)),PSJTMPON["V":$GET(^PS(55,PSGP,"IV",+PSJTMPON,0)),1:"")
+90 SET ND2=$SELECT(PSJTMPON["U":$GET(^PS(55,PSGP,5,+PSJTMPON,2)),PSJTMPON["P":$GET(^PS(53.1,+PSJTMPON,2)),PSJTMPON["V":$GET(^PS(55,PSGP,"IV",+PSJTMPON,2)),1:"")
+91 ;*315
SET ND2P1=$SELECT(PSJTMPON["U":$GET(^PS(55,PSGP,5,+PSJTMPON,2.1)),PSJTMPON["P":$GET(^PS(53.1,+PSJTMPON,2.1)),1:"")
+92 SET TMPSTR=$SELECT(PSJTMPON["P"!(PSJTMPON["U"):$PIECE(ND2,"^",2),PSJTMPON["V":$PIECE(ND0,"^",2),1:"")
SET TMPSTR($PIECE(TMPSTR,"."))=""
+93 SET TMPCLN=$SELECT(PSJTMPON["P":+$GET(^PS(53.1,+PSJTMPON,"DSS")),PSJTMPON["U":+$GET(^PS(55,+$GET(PSGP),5,+PSJTMPON,8)),PSJTMPON["V":+$GET(^PS(55,$GET(PSGP),"IV",+PSJTMPON,"DSS")),1:"")
+94 if 'TMPCLN
QUIT
IF $ORDER(TMPCLNAR(""))
IF $ORDER(TMPCLNAR(""))'=TMPCLN
SET PSJABORT=1
+95 SET TMPCLNAR(+TMPCLN)=""
End DoDot:1
+96 SET TMPSTR=""
FOR
SET TMPSTR=$ORDER(TMPSTR(TMPSTR))
if 'TMPSTR
QUIT
SET TMPSTR(0)=$GET(TMPSTR(0))+1
+97 IF $GET(PSJABORT)!($GET(TMPSTR(0))>1)
Begin DoDot:1
+98 KILL DIR
SET DIR("A",1)=" You have selected orders"_$SELECT($GET(PSJABORT):" from different clinics",1:" with different Start Date/Times")_" "
+99 IF $GET(PSJABORT)&($GET(TMPSTR(0))>1)
SET DIR("A",2)=" and with different Start Date/Times."
+100 SET DIR("A",3)=""
SET DIR("A",4)=""
+101 WRITE !
NEW X,Y
SET DIR("A")="Do you want to continue"
SET DIR(0)="Y"
DO ^DIR
SET PSJABORT=$SELECT(Y>0:1,1:2)
End DoDot:1
+102 QUIT
+103 ;
NEWCLN ; Clean up Order variables
+1 KILL PSGNEDFD,PSGOEE,PSGOEEWF,PSGOORD,PSGPD,PSGPDN,PSGPDRGN,PSGRDTX,PSGS0Y,PSJCOM,PSJL,PSJNOO,PSJQMSG
+2 KILL PSJTMPON,VALMBCK,VALMCNT,VALMQUIT
+3 QUIT
