- PSGOECS ;BIR/CML3-CANCEL SELECTED ORDERS ;02 Mar 99 / 9:29 AM
- ;;5.0; INPATIENT MEDICATIONS ;**23,29,44,58,81,110,134,181**;16 DEC 97;Build 190
- ;
- ; Reference to FULL^VALM1 is supported by DBIA# 10116.
- ; Reference to ^PS(55 is supported by DBIA# 2191.
- ; Reference to ^PSSLOCK is supported by DBIA #2789.
- ;
- AM ;
- W !,"...marking ",$P(X,U),"..." S $P(^PS(55,PSGP,5,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT,PSGAL("C")=13040 W "." D ^PSGAL5 W "."
- I $D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
- Q
- ;
- NM ;
- W !,"...marking ",$P(X,U),"..." S $P(^PS(53.1,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT W "."
- I $D(PSJSYSO) S PSGORD=+PSGORD_"N",PSGPOSD=PSGDT,PSGPOSA="C" D ENPOS^PSGVDS
- Q
- ;
- AC ; discontinue active order
- K DA S DA(1)=PSGP,DA=+PSGORD
- S X=$G(^PS(55,PSGP,5,DA,.2))
- I $P(X,U,4)="D" W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON DONE ORDER",!,$C(7) HANG 1 Q
- NEW XX S XX=$P(^PS(55,PSGP,5,DA,0),U,9)
- I $S(XX="E":1,XX="D":1,XX="DE":1,1:0) W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON "_$$CODES^PSIVUTL(XX,55.06,28)_" ORDER",!,$C(7) HANG 1 Q
- S X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD)
- I '$P(PSJSYSP0,"^",5) D AM Q
- W !,"...discontinuing ",$P(X,U),"...",! S PSGAL("C")=PSJSYSU*10+4000 D ^PSGAL5
- S PSGALR=20,DIE="^PS(55,"_PSGP_",5,",DR="136////@;28////D;Q;34////"_PSGDT_$S(PSJSYSU:"",1:";49////1"),DP=55.06,$P(^(2),"^",3)=$P(^PS(55,PSGP,5,DA,2),"^",4) D ^DIE S ^PS(55,"AUE",PSGP,DA)=""
- D EN1^PSJHL2(PSGP,"OD",PSGORD) S DA(1)=PSGP,DA=+PSGORD
- I PSJSYSL S $P(^PS(55,PSGP,5,DA,7),"^",1,2)=PSGDT_"^D",PSGTOL=2,PSGUOW=DUZ,PSGTOO=1 D ENL^PSGVDS
- Q
- ;
- NC ; discontinue non-verified order
- I $P($G(^PS(53.1,+PSGORD,0)),U,24)="R" S PSJDCTYP=$$PNDRNA^PSGOEC(PSGORD) I $G(PSJDCTYP)'=1 D PNDRN($G(PSJDCTYP)) Q
- NC2 ; Called from PNDRN to discontinue both pending renewal and original order
- K DA S DA=+PSGORD,X=$G(^PS(53.1,DA,.2)),X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD)
- I $S($P(PSJSYSP0,"^",5):0,'$D(^PS(53.1,DA,4)):1,1:$P(^(4),"^",7)'=DUZ) D NM Q
- W !,"...discontinuing ",$P(X,U),"...",! S DIE="^PS(53.1,",DR="28////D"_$S(PSJSYSU:"",1:";42////1") D ^DIE
- D EN1^PSJHL2(PSGP,"OC",PSGORD)
- S DA=+PSGORD I PSJSYSL,PSJSYSL<3 S $P(^PS(53.1,DA,7),"^",1,2)=PSGDT_"^D",PSGTOO=2,PSGUOW=DUZ,PSGTOL=2 D ENL^PSGVDS
- I $G(PSJDCTYP) D UNL^PSSLOCK(DFN,PSGORD)
- Q
- ;
- EN ; enter here
- I $G(PSJIVPRF) D ^PSIVSPDC Q ;Use for Speed DC in IV Order Profile
- D FULL^VALM1
- EN1 ;
- S (PSGONC,PSGLMT)=PSJOCNT,PSGONW="C" D ENWO^PSGON I "^"[X K X G RESET
- D NOW^%DTC S PSGDT=+$E(%,1,12)
- W ! F PSGOECS=1:1:PSGODDD F PSGOECS1=1:1 S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1) Q:'PSGOECS2 D
- .S PSGORD=^TMP("PSJON",$J,PSGOECS2) ; I $P($G(@($S((PSGORD["A")!(PSGORD["U"):"^PS(55,"_PSGP_",5,",(PSGORD["V"):"^PS(55,"_PSGP_",""IV"",",1:"^PS(53.1,")_(+PSGORD)_",0)")),"^",21) Q
- S PSJNOO=$$ENNOO^PSJUTL5("D") G:PSJNOO<0 EN1
- ;Prompt for requesting provider
- W ! I '$$REQPROV^PSGOEC G EN1
- W !
- ;
- ;F PSGOECS=1:1:PSGODDD F PSGOECS1=1:1 S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1) Q:'PSGOECS2 S (ON,PSGORD)=^TMP("PSJON",$J,PSGOECS2) D:(PSGORD["U") AC D:(PSGORD["P") NC D:(PSGORD["V") SPDCIV^PSIVSPDC
- ;Replaced above line with block structure below.
- N COMFLG,PSJCOM S (EXITLOOP,PSJCOM)=0
- F PSGOECS=1:1:PSGODDD D
- .F PSGOECS1=1:1 D Q:EXITLOOP=1
- ..S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1)
- ..I 'PSGOECS2 S EXITLOOP=1 Q
- ..S (ON,PSGORD)=^TMP("PSJON",$J,PSGOECS2)
- ..I PSGORD=+PSGORD D DCCOM Q
- ..I '$$LS^PSSLOCK(DFN,PSGORD) D Q
- ... W:PSGORD'["V" !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 Q
- ... W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D W !,"NO ACTION WAS TAKEN",!,$C(7) HANG 1
- ....F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X D
- .....W !,$G(PSJOC(ON,X))
- ..D CHKCOM I COMFLG D
- ... I PSGORD'["V" W !,$P($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$C(7) HANG 1 Q
- ... W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D W !,"NO ACTION WAS TAKEN",!,$C(7) HANG 1
- ....F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X D
- .....W !,$G(PSJOC(ON,X))
- ..Q:PSJCOM
- ..D:(PSGORD["U") AC
- ..D:(PSGORD["P") NC
- ..D:(PSGORD["V") SPDCIV^PSIVSPDC
- ..; Call the unlock procedure
- ..D UNL^PSSLOCK(DFN,PSGORD)
- S X=""
- RESET ;
- I $G(PSGORD)["V" D INIT^PSJLMHED(3) S VALMBK="R" G DONE
- D INIT^PSJLMHED(1) S VALMBCK="R"
- ;
- DONE ;
- K DA,DIE,DP,DR,PSGAL,PSGALR,PSGLMT,PSGODDD,PSGOECS,PSGOECS1,PSGOECS2,PSGONW,PSGORD,PSGPOSA,PSGPOSD,PSGTOL,PSGTOO,PSGUOW,ORIFN,ORETURN,ORNATR
- Q
- ;
- DCOR ; Create DC order/update stop date in OE/RR.
- S PSOC=$S(PSGORD["P":"OC",PSGORD["N":"OC",1:"OD")
- D EN1^PSJHL2(PSGP,PSOC,PSGORD)
- Q
- ;
- ENOR ;
- K DA S PSGEDIT=$S($D(PSGEDIT):PSGEDIT,1:"D"),CF=1,PSGALR=20,DA=+PSGORD,T="" I PSGORD'["U",(PSGORD'["O") D:CF NSET^PSGOEC D NC^PSGOEC D ENOR2 G DONE^PSGOEC
- S DA(1)=PSGP D:CF ASET^PSGOEC D AC^PSGOEC
- G DONE^PSGOEC
- ;
- ENOR2 ;Check to see if order being DC'd is a Pending Renewal and is being DC'd due to edit.
- I PSGEDIT="DE",$P(^PS(53.1,+PSGORD,0),U,25),$P(^PS(53.1,+PSGORD,0),U,24)="R",PSGSD<$P($G(^PS(55,PSGP,5,+$P(^PS(53.1,+PSGORD,0),U,25),2)),U,4) D
- .K DA,DR S DA(1)=PSGP,DA=+$P(^PS(53.1,+PSGORD,0),U,25),DIE="^PS(55,"_PSGP_",5,",DR="34////"_PSGSD_";25////"_$P($G(^PS(55,PSGP,5,+$P(^PS(53.1,+PSGORD,0),U,25),2)),U,4)
- .D ^DIE,EN1^PSJHL2(PSGP,"XX",$P(^PS(53.1,+PSGORD,0),U,25))
- Q
- ;
- CHKCOM ;Check to see if order is part of complex order series.
- S PSJCOM=$S(PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,.2)),U,8),PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),U,8),1:$P($G(^PS(53.1,+PSGORD,.2)),U,8)),COMFLG=0
- N PSJSTAT S PSJSTAT=$S(PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,0)),"^",17),PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,0)),"^",9),1:$P($G(^PS(53.1,+PSGORD,0)),"^",9))
- Q:'PSJCOM I "DE"[PSJSTAT Q
- W ! I PSGORD["V" N PSJLINE S PSJLINE=1 D DSPLORDV^PSJLMUT1(PSGP,PSGORD) D
- .F X=0:0 S X=$O(PSJOC(ON,X)) Q:'X D
- ..W !,$G(PSJOC(ON,X))
- I PSGORD["U" W !,$P($$DRUGNAME^PSJLMUTL(PSGP,PSGORD),"^",1) D
- .W !!,"is part of a complex order. If you discontinue this order the following orders",!,"will be discontinued too (unless the stop date has already been reached)." D CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD)
- F W !!,"Do you want to discontinue this series of complex orders" S %=1 D YN^DICN Q:%
- I %'=1 S COMFLG=1 Q
- N O,OO S O=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" D Q:COMFLG
- .Q:OO=PSGORD I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q
- Q:COMFLG
- N O,OO S O=0,OO="" F S O=$O(^PS(55,"ACX",PSJCOM,O)) Q:'O F S OO=$O(^PS(55,"ACX",PSJCOM,O,OO)) Q:OO="" D
- .I (OO["U") N PSGORD S PSGORD=OO D AC
- .I (OO["V") N PSGORD S (ON,PSGORD)=OO D SPDCIV^PSIVSPDC
- .D UNL^PSSLOCK(DFN,PSGORD)
- Q
- ;
- DCCOM ;DC pending/non-verified complex order
- I '$$LOCK^PSJOEA(DFN,PSGORD) W !,"Order # ",PSGOECS2," could not be discontinued.",!,$C(7) HANG 1 Q
- N PSGORD1 S PSGORD1=PSGORD
- N PSJO S PSJO=0 F S PSJO=$O(^PS(53.1,"ACX",PSGORD1,PSJO)) Q:'PSJO S PSGORD=PSJO_"P" D NC
- Q
- PNDRN(PSJDCTYP) ; Discontinue both pending renewal and original order
- N TMPORD S TMPORD=$G(PSGORD)
- I PSJDCTYP=2 S PSJDCTYP=1 D NC2 Q:'$G(PSJDCTYP) D
- .I ($G(PSJNOO)<0) Q
- .N ND5310 S ND5310=$G(^PS(53.1,+PSGORD,0))
- .N PSGORD S PSGORD=$P(ND5310,"^",25) I PSGORD S PSJDCTYP=2 D
- ..I '$$LS^PSSLOCK(DFN,PSGORD) K PSJDCTYP Q
- ..D @$S(PSGORD["U":"AC",PSGORD["V":"SPDCIV^PSIVSPDC",1:"")
- S PSGORD=TMPORD
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOECS 7469 printed Feb 18, 2025@23:28:29 Page 2
- PSGOECS ;BIR/CML3-CANCEL SELECTED ORDERS ;02 Mar 99 / 9:29 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**23,29,44,58,81,110,134,181**;16 DEC 97;Build 190
- +2 ;
- +3 ; Reference to FULL^VALM1 is supported by DBIA# 10116.
- +4 ; Reference to ^PS(55 is supported by DBIA# 2191.
- +5 ; Reference to ^PSSLOCK is supported by DBIA #2789.
- +6 ;
- AM ;
- +1 WRITE !,"...marking ",$PIECE(X,U),"..."
- SET $PIECE(^PS(55,PSGP,5,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT
- SET PSGAL("C")=13040
- WRITE "."
- DO ^PSGAL5
- WRITE "."
- +2 IF $DATA(PSJSYSO)
- SET PSGORD=+PSGORD_"A"
- SET PSGPOSA="C"
- SET PSGPOSD=PSGDT
- DO ENPOS^PSGVDS
- +3 QUIT
- +4 ;
- NM ;
- +1 WRITE !,"...marking ",$PIECE(X,U),"..."
- SET $PIECE(^PS(53.1,DA,4),"^",11,14)="^1^"_DUZ_"^"_PSGDT
- WRITE "."
- +2 IF $DATA(PSJSYSO)
- SET PSGORD=+PSGORD_"N"
- SET PSGPOSD=PSGDT
- SET PSGPOSA="C"
- DO ENPOS^PSGVDS
- +3 QUIT
- +4 ;
- AC ; discontinue active order
- +1 KILL DA
- SET DA(1)=PSGP
- SET DA=+PSGORD
- +2 SET X=$GET(^PS(55,PSGP,5,DA,.2))
- +3 IF $PIECE(X,U,4)="D"
- WRITE !,$PIECE($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON DONE ORDER",!,$CHAR(7)
- HANG 1
- QUIT
- +4 NEW XX
- SET XX=$PIECE(^PS(55,PSGP,5,DA,0),U,9)
- +5 IF $SELECT(XX="E":1,XX="D":1,XX="DE":1,1:0)
- WRITE !,$PIECE($$DRUGNAME^PSJLMUTL(DFN,PSGORD),U,1),!,"NO ACTION WAS TAKEN ON "_$$CODES^PSIVUTL(XX,55.06,28)_" ORDER",!,$CHAR(7)
- HANG 1
- QUIT
- +6 SET X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD)
- +7 IF '$PIECE(PSJSYSP0,"^",5)
- DO AM
- QUIT
- +8 WRITE !,"...discontinuing ",$PIECE(X,U),"...",!
- SET PSGAL("C")=PSJSYSU*10+4000
- DO ^PSGAL5
- +9 SET PSGALR=20
- SET DIE="^PS(55,"_PSGP_",5,"
- SET DR="136////@;28////D;Q;34////"_PSGDT_$SELECT(PSJSYSU:"",1:";49////1")
- SET DP=55.06
- SET $PIECE(^(2),"^",3)=$PIECE(^PS(55,PSGP,5,DA,2),"^",4)
- DO ^DIE
- SET ^PS(55,"AUE",PSGP,DA)=""
- +10 DO EN1^PSJHL2(PSGP,"OD",PSGORD)
- SET DA(1)=PSGP
- SET DA=+PSGORD
- +11 IF PSJSYSL
- SET $PIECE(^PS(55,PSGP,5,DA,7),"^",1,2)=PSGDT_"^D"
- SET PSGTOL=2
- SET PSGUOW=DUZ
- SET PSGTOO=1
- DO ENL^PSGVDS
- +12 QUIT
- +13 ;
- NC ; discontinue non-verified order
- +1 IF $PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)="R"
- SET PSJDCTYP=$$PNDRNA^PSGOEC(PSGORD)
- IF $GET(PSJDCTYP)'=1
- DO PNDRN($GET(PSJDCTYP))
- QUIT
- NC2 ; Called from PNDRN to discontinue both pending renewal and original order
- +1 KILL DA
- SET DA=+PSGORD
- SET X=$GET(^PS(53.1,DA,.2))
- SET X=$$DRUGNAME^PSJLMUTL(PSGP,PSGORD)
- +2 IF $SELECT($PIECE(PSJSYSP0,"^",5):0,'$DATA(^PS(53.1,DA,4)):1,1:$PIECE(^(4),"^",7)'=DUZ)
- DO NM
- QUIT
- +3 WRITE !,"...discontinuing ",$PIECE(X,U),"...",!
- SET DIE="^PS(53.1,"
- SET DR="28////D"_$SELECT(PSJSYSU:"",1:";42////1")
- DO ^DIE
- +4 DO EN1^PSJHL2(PSGP,"OC",PSGORD)
- +5 SET DA=+PSGORD
- IF PSJSYSL
- IF PSJSYSL<3
- SET $PIECE(^PS(53.1,DA,7),"^",1,2)=PSGDT_"^D"
- SET PSGTOO=2
- SET PSGUOW=DUZ
- SET PSGTOL=2
- DO ENL^PSGVDS
- +6 IF $GET(PSJDCTYP)
- DO UNL^PSSLOCK(DFN,PSGORD)
- +7 QUIT
- +8 ;
- EN ; enter here
- +1 ;Use for Speed DC in IV Order Profile
- IF $GET(PSJIVPRF)
- DO ^PSIVSPDC
- QUIT
- +2 DO FULL^VALM1
- EN1 ;
- +1 SET (PSGONC,PSGLMT)=PSJOCNT
- SET PSGONW="C"
- DO ENWO^PSGON
- IF "^"[X
- KILL X
- GOTO RESET
- +2 DO NOW^%DTC
- SET PSGDT=+$EXTRACT(%,1,12)
- +3 WRITE !
- FOR PSGOECS=1:1:PSGODDD
- FOR PSGOECS1=1:1
- SET PSGOECS2=$PIECE(PSGODDD(PSGOECS),",",PSGOECS1)
- if 'PSGOECS2
- QUIT
- Begin DoDot:1
- +4 ; I $P($G(@($S((PSGORD["A")!(PSGORD["U"):"^PS(55,"_PSGP_",5,",(PSGORD["V"):"^PS(55,"_PSGP_",""IV"",",1:"^PS(53.1,")_(+PSGORD)_",0)")),"^",21) Q
- SET PSGORD=^TMP("PSJON",$JOB,PSGOECS2)
- End DoDot:1
- +5 SET PSJNOO=$$ENNOO^PSJUTL5("D")
- if PSJNOO<0
- GOTO EN1
- +6 ;Prompt for requesting provider
- +7 WRITE !
- IF '$$REQPROV^PSGOEC
- GOTO EN1
- +8 WRITE !
- +9 ;
- +10 ;F PSGOECS=1:1:PSGODDD F PSGOECS1=1:1 S PSGOECS2=$P(PSGODDD(PSGOECS),",",PSGOECS1) Q:'PSGOECS2 S (ON,PSGORD)=^TMP("PSJON",$J,PSGOECS2) D:(PSGORD["U") AC D:(PSGORD["P") NC D:(PSGORD["V") SPDCIV^PSIVSPDC
- +11 ;Replaced above line with block structure below.
- +12 NEW COMFLG,PSJCOM
- SET (EXITLOOP,PSJCOM)=0
- +13 FOR PSGOECS=1:1:PSGODDD
- Begin DoDot:1
- +14 FOR PSGOECS1=1:1
- Begin DoDot:2
- +15 SET PSGOECS2=$PIECE(PSGODDD(PSGOECS),",",PSGOECS1)
- +16 IF 'PSGOECS2
- SET EXITLOOP=1
- QUIT
- +17 SET (ON,PSGORD)=^TMP("PSJON",$JOB,PSGOECS2)
- +18 IF PSGORD=+PSGORD
- DO DCCOM
- QUIT
- +19 IF '$$LS^PSSLOCK(DFN,PSGORD)
- Begin DoDot:3
- +20 if PSGORD'["V"
- WRITE !,$PIECE($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$CHAR(7)
- HANG 1
- QUIT
- +21 WRITE !
- IF PSGORD["V"
- NEW PSJLINE
- SET PSJLINE=1
- DO DSPLORDV^PSJLMUT1(PSGP,PSGORD)
- Begin DoDot:4
- +22 FOR X=0:0
- SET X=$ORDER(PSJOC(ON,X))
- if 'X
- QUIT
- Begin DoDot:5
- +23 WRITE !,$GET(PSJOC(ON,X))
- End DoDot:5
- End DoDot:4
- WRITE !,"NO ACTION WAS TAKEN",!,$CHAR(7)
- HANG 1
- End DoDot:3
- QUIT
- +24 DO CHKCOM
- IF COMFLG
- Begin DoDot:3
- +25 IF PSGORD'["V"
- WRITE !,$PIECE($$DRUGNAME^PSJLMUTL(DFN,PSGORD),"^",1),!,"NO ACTION WAS TAKEN",!,$CHAR(7)
- HANG 1
- QUIT
- +26 WRITE !
- IF PSGORD["V"
- NEW PSJLINE
- SET PSJLINE=1
- DO DSPLORDV^PSJLMUT1(PSGP,PSGORD)
- Begin DoDot:4
- +27 FOR X=0:0
- SET X=$ORDER(PSJOC(ON,X))
- if 'X
- QUIT
- Begin DoDot:5
- +28 WRITE !,$GET(PSJOC(ON,X))
- End DoDot:5
- End DoDot:4
- WRITE !,"NO ACTION WAS TAKEN",!,$CHAR(7)
- HANG 1
- End DoDot:3
- +29 if PSJCOM
- QUIT
- +30 if (PSGORD["U")
- DO AC
- +31 if (PSGORD["P")
- DO NC
- +32 if (PSGORD["V")
- DO SPDCIV^PSIVSPDC
- +33 ; Call the unlock procedure
- +34 DO UNL^PSSLOCK(DFN,PSGORD)
- End DoDot:2
- if EXITLOOP=1
- QUIT
- End DoDot:1
- +35 SET X=""
- RESET ;
- +1 IF $GET(PSGORD)["V"
- DO INIT^PSJLMHED(3)
- SET VALMBK="R"
- GOTO DONE
- +2 DO INIT^PSJLMHED(1)
- SET VALMBCK="R"
- +3 ;
- DONE ;
- +1 KILL DA,DIE,DP,DR,PSGAL,PSGALR,PSGLMT,PSGODDD,PSGOECS,PSGOECS1,PSGOECS2,PSGONW,PSGORD,PSGPOSA,PSGPOSD,PSGTOL,PSGTOO,PSGUOW,ORIFN,ORETURN,ORNATR
- +2 QUIT
- +3 ;
- DCOR ; Create DC order/update stop date in OE/RR.
- +1 SET PSOC=$SELECT(PSGORD["P":"OC",PSGORD["N":"OC",1:"OD")
- +2 DO EN1^PSJHL2(PSGP,PSOC,PSGORD)
- +3 QUIT
- +4 ;
- ENOR ;
- +1 KILL DA
- SET PSGEDIT=$SELECT($DATA(PSGEDIT):PSGEDIT,1:"D")
- SET CF=1
- SET PSGALR=20
- SET DA=+PSGORD
- SET T=""
- IF PSGORD'["U"
- IF (PSGORD'["O")
- if CF
- DO NSET^PSGOEC
- DO NC^PSGOEC
- DO ENOR2
- GOTO DONE^PSGOEC
- +2 SET DA(1)=PSGP
- if CF
- DO ASET^PSGOEC
- DO AC^PSGOEC
- +3 GOTO DONE^PSGOEC
- +4 ;
- ENOR2 ;Check to see if order being DC'd is a Pending Renewal and is being DC'd due to edit.
- +1 IF PSGEDIT="DE"
- IF $PIECE(^PS(53.1,+PSGORD,0),U,25)
- IF $PIECE(^PS(53.1,+PSGORD,0),U,24)="R"
- IF PSGSD<$PIECE($GET(^PS(55,PSGP,5,+$PIECE(^PS(53.1,+PSGORD,0),U,25),2)),U,4)
- Begin DoDot:1
- +2 KILL DA,DR
- SET DA(1)=PSGP
- SET DA=+$PIECE(^PS(53.1,+PSGORD,0),U,25)
- SET DIE="^PS(55,"_PSGP_",5,"
- SET DR="34////"_PSGSD_";25////"_$PIECE($GET(^PS(55,PSGP,5,+$PIECE(^PS(53.1,+PSGORD,0),U,25),2)),U,4)
- +3 DO ^DIE
- DO EN1^PSJHL2(PSGP,"XX",$PIECE(^PS(53.1,+PSGORD,0),U,25))
- End DoDot:1
- +4 QUIT
- +5 ;
- CHKCOM ;Check to see if order is part of complex order series.
- +1 SET PSJCOM=$SELECT(PSGORD["V":$PIECE($GET(^PS(55,PSGP,"IV",+PSGORD,.2)),U,8),PSGORD["U":$PIECE($GET(^PS(55,PSGP,5,+PSGORD,.2)),U,8),1:$PIECE($GET(^PS(53.1,+PSGORD,.2)),U,8))
- SET COMFLG=0
- +2 NEW PSJSTAT
- SET PSJSTAT=$SELECT(PSGORD["V":$PIECE($GET(^PS(55,PSGP,"IV",+PSGORD,0)),"^",17),PSGORD["U":$PIECE($GET(^PS(55,PSGP,5,+PSGORD,0)),"^",9),1:$PIECE($GET(^PS(53.1,+PSGORD,0)),"^",9))
- +3 if 'PSJCOM
- QUIT
- IF "DE"[PSJSTAT
- QUIT
- +4 WRITE !
- IF PSGORD["V"
- NEW PSJLINE
- SET PSJLINE=1
- DO DSPLORDV^PSJLMUT1(PSGP,PSGORD)
- Begin DoDot:1
- +5 FOR X=0:0
- SET X=$ORDER(PSJOC(ON,X))
- if 'X
- QUIT
- Begin DoDot:2
- +6 WRITE !,$GET(PSJOC(ON,X))
- End DoDot:2
- End DoDot:1
- +7 IF PSGORD["U"
- WRITE !,$PIECE($$DRUGNAME^PSJLMUTL(PSGP,PSGORD),"^",1)
- Begin DoDot:1
- +8 WRITE !!,"is part of a complex order. If you discontinue this order the following orders",!,"will be discontinued too (unless the stop date has already been reached)."
- DO CMPLX^PSJCOM1(PSGP,PSJCOM,PSGORD)
- End DoDot:1
- +9 FOR
- WRITE !!,"Do you want to discontinue this series of complex orders"
- SET %=1
- DO YN^DICN
- if %
- QUIT
- +10 IF %'=1
- SET COMFLG=1
- QUIT
- +11 NEW O,OO
- SET O=0
- SET OO=""
- FOR
- SET O=$ORDER(^PS(55,"ACX",PSJCOM,O))
- if 'O
- QUIT
- FOR
- SET OO=$ORDER(^PS(55,"ACX",PSJCOM,O,OO))
- if OO=""
- QUIT
- Begin DoDot:1
- +12 if OO=PSGORD
- QUIT
- IF '$$LS^PSSLOCK(DFN,OO)
- SET COMFLG=1
- QUIT
- End DoDot:1
- if COMFLG
- QUIT
- +13 if COMFLG
- QUIT
- +14 NEW O,OO
- SET O=0
- SET OO=""
- FOR
- SET O=$ORDER(^PS(55,"ACX",PSJCOM,O))
- if 'O
- QUIT
- FOR
- SET OO=$ORDER(^PS(55,"ACX",PSJCOM,O,OO))
- if OO=""
- QUIT
- Begin DoDot:1
- +15 IF (OO["U")
- NEW PSGORD
- SET PSGORD=OO
- DO AC
- +16 IF (OO["V")
- NEW PSGORD
- SET (ON,PSGORD)=OO
- DO SPDCIV^PSIVSPDC
- +17 DO UNL^PSSLOCK(DFN,PSGORD)
- End DoDot:1
- +18 QUIT
- +19 ;
- DCCOM ;DC pending/non-verified complex order
- +1 IF '$$LOCK^PSJOEA(DFN,PSGORD)
- WRITE !,"Order # ",PSGOECS2," could not be discontinued.",!,$CHAR(7)
- HANG 1
- QUIT
- +2 NEW PSGORD1
- SET PSGORD1=PSGORD
- +3 NEW PSJO
- SET PSJO=0
- FOR
- SET PSJO=$ORDER(^PS(53.1,"ACX",PSGORD1,PSJO))
- if 'PSJO
- QUIT
- SET PSGORD=PSJO_"P"
- DO NC
- +4 QUIT
- PNDRN(PSJDCTYP) ; Discontinue both pending renewal and original order
- +1 NEW TMPORD
- SET TMPORD=$GET(PSGORD)
- +2 IF PSJDCTYP=2
- SET PSJDCTYP=1
- DO NC2
- if '$GET(PSJDCTYP)
- QUIT
- Begin DoDot:1
- +3 IF ($GET(PSJNOO)<0)
- QUIT
- +4 NEW ND5310
- SET ND5310=$GET(^PS(53.1,+PSGORD,0))
- +5 NEW PSGORD
- SET PSGORD=$PIECE(ND5310,"^",25)
- IF PSGORD
- SET PSJDCTYP=2
- Begin DoDot:2
- +6 IF '$$LS^PSSLOCK(DFN,PSGORD)
- KILL PSJDCTYP
- QUIT
- +7 DO @$SELECT(PSGORD["U":"AC",PSGORD["V":"SPDCIV^PSIVSPDC",1:"")
- End DoDot:2
- End DoDot:1
- +8 SET PSGORD=TMPORD
- +9 QUIT
