- PSGOERI ;BIR/CML3 - REINSTATE A DC'D ORDER ;06 Aug 98 / 2:17 PM
- ;;5.0;INPATIENT MEDICATIONS ;**17,27,31,88,110,137,181,320**;16 DEC 97;Build 7
- ;
- ; Reference to ^PS(55 is supported by DBIA# 2191
- ;
- ENRI ;
- S PSGALR=80,PSGFD=$P($G(^PS(55,PSGP,5,+PSGORD,2)),"^",3) I 'PSGFD W:'$D(PSJUNDC) $C(7),$C(7),!?3,"I CANNOT REINSTATE THIS ORDER! THE OLD STOP DATE IS MISSING!" Q
- I PSGFD'>PSGDT Q:$D(PSJUNDC) W !!,"This order has technically expired as of ",$$ENDTC^PSGMI,"." F S %=1 W !!,"Do you want to RENEW this order" D YN^DICN Q:% D
- .W !!?2,"This order has expired, and cannot be renewed. But the order can be",!,"reinstated. Answer 'YES' to reinstate the order now. Answer 'NO' (or '^') if",!,"you do not want to reinstate this order now."
- I PSGFD'>PSGDT G:%'=1 DONE S PSGRRF=0 D NEW^PSGOER,DONE^PSGOER G DONE
- W:'$D(PSJUNDC) !!,"...reinstating this order..."
- ;Create a list of recipients beyond normal mail group
- D:$D(PSJUNDC) ; do only if from movement deletion
- .I $P(^PS(55,PSGP,5,+PSGORD,4),U,1)'="" S PSJSENTO($J,$P(^PS(55,PSGP,5,+PSGORD,4),U,1))="" ; Record verifying Nurse
- .I $P(^PS(55,PSGP,5,+PSGORD,4),U,3)'="" S PSJSENTO($J,$P(^PS(55,PSGP,5,+PSGORD,4),U,3))="" ; Record verifying Pharmacist
- .I $P(^PS(55,PSGP,5,+PSGORD,4),U,5)'="" S PSJSENTO($J,$P(^PS(55,PSGP,5,+PSGORD,4),U,5))="" ; Record Physician
- .I $P(^PS(55,PSGP,5,+PSGORD,0),U,2)'="" S PSJSENTO($J,$P(^PS(55,PSGP,5,+PSGORD,0),U,2))="" ; Record Provider
- ;If a duplicate order exists do not reinstate the older one. Record in ^TMP for later advice in auto e-mail (PSJADT2)
- D NOW^%DTC
- I $D(PSJUNDC) I $$CHECKDUP^PSGOERI(PSGP,+PSGORD) S ^TMP("PSJNOTUNDC",$J,PSGP,PSGORD_"U")="" G DONE
- ;S DR=$S(+$P($G(^PS(55,PSGP,5,+PSGORD,4)),U,18)=1:"28///H",+$P($G(^(4)),U,26)=1:"28///H",1:"28////A")_";34////"_PSGFD_";136////@"
- S DR=$S(+$P($G(^PS(55,PSGP,5,+PSGORD,4)),U,26)=1:"28///H;136////HP",+$P($G(^(4)),U,18)=1:"28///H;136////@",1:"28////A;136////@")_";34////"_PSGFD
- S Z=$G(^PS(55,PSGP,5,+PSGORD,4)),$P(Z,U,11)="",$P(Z,"^",15,17)="^^" S:'$D(PSJUNDC) $P(Z,"^",PSJSYSU,PSJSYSU+1)=DUZ_"^"_PSGDT S ^(4)=Z W "."
- N CHKIT S CHKIT=$G(^PS(55,PSGP,5,+PSGORD,0)) I $P(CHKIT,U,26)["P",($P(CHKIT,U,27)="R") S DR=DR_";105///@;107///@"
- S DIE="^PS(55,"_PSGP_",5,",DA(1)=PSGP,DA=+PSGORD,PSGAL("C")=$S($D(PSJUNDC):40,1:(PSJSYSU*10))+18500 D ^PSGAL5 W "." D ^DIE W "."
- S X=$P(^PS(55,PSGP,5,+PSGORD,0),"^",20),$P(^(0),"^",20)="" K:X ^PS(55,"AUDDD",X,PSGP,+PSGORD) ;Removed cross reference after reinstate order.
- ;S X=$O(^ORD(101,"B","PS EVSEND OR",0))_";ORD(101,",PSOC="SC",PSJORDER=$$ORDER^PSJHLU(PSGORD) D EN1^XQOR:X K X
- S ^TMP("PSJUNDC",$J,PSGP,PSGORD_"U")=""
- D EN1^PSJHL2(PSGP,"SC",+PSGORD_"U",$S($D(PSJUNDC):"AUTO REINSTATED",1:"REINSTATED"))
- Q:$S('$D(PSJUNDC):0,PSGALO=18540:1,1:'$P($G(PSJSYSW0),U,15))
- S PSGTOL=$S($D(PSJUNDC):3,1:2),PSGUOW=$S($D(PSJUNDC):PSJUOW,1:DUZ)
- I $D(^PS(53.41,1,1,+PSGUOW,1,PSGP,1,1,1,+PSGORD)) K DIK,DA S DIK="^PS(53.41,"_1_",1,"_+PSGUOW_",1,"_PSGP_",1,1,1,",DA=+PSGORD,DA(1)=1,DA(2)=PSGP,DA(3)=+PSGUOW,DA(4)=1 D ^DIK
- E D
- .S X=0 S:$D(PSJUNDC) X=$O(^PS(59.6,"B",+PSGUOW,0)),X=$P($G(^PS(59.6,+X,0)),U,15)
- .I $S(X:1,'PSJSYSL:0,PSJSYSL<3:1,1:$P(^PS(55,PSGP,5,DA,4),"^",+PSJSYSU'=3+9)) D
- ..K DA S DA=+PSGORD,DA(1)=PSGP,$P(^PS(55,PSGP,5,DA,7),"^",1,2)=PSGDT_"^RE",PSGTOO=1,PSGUOW=$S($D(PSJUNDC):+PSJUOW,1:DUZ) D ENL^PSGVDS W "."
- W:'$D(PSJUNDC) ".DONE!" Q
- ;
- DONE ;
- K DA,DIE,DR,PSGAL,PSGALR,PSGFD,PSGID,PSGOD,RF,Z
- Q
- CHECKDUP(PSGP,PSGORD) ;
- N Z,ZZ,PSJCOM
- S FOUND=0
- S PSGX=+$G(^PS(55,PSGP,5,+PSGORD,.2)),PSJCOM=+$P($G(^(.2)),"^",8)
- I PSGX'="" D
- .F Z=%:0 S Z=$O(^PS(55,+PSGP,5,"AUS",Z)) Q:'Z!FOUND D
- ..F ZZ=0:0 S ZZ=$O(^PS(55,+PSGP,5,"AUS",Z,ZZ)) Q:'ZZ!FOUND D
- ...I PSJCOM>0 Q:+$P($G(^PS(55,+PSGP,5,ZZ,.2)),"^",8)=PSJCOM
- ...I +$G(^PS(55,+PSGP,5,ZZ,.2))=PSGX D
- ....S FOUND=1
- Q FOUND
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOERI 3844 printed Feb 18, 2025@23:28:47 Page 2
- PSGOERI ;BIR/CML3 - REINSTATE A DC'D ORDER ;06 Aug 98 / 2:17 PM
- +1 ;;5.0;INPATIENT MEDICATIONS ;**17,27,31,88,110,137,181,320**;16 DEC 97;Build 7
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA# 2191
- +4 ;
- ENRI ;
- +1 SET PSGALR=80
- SET PSGFD=$PIECE($GET(^PS(55,PSGP,5,+PSGORD,2)),"^",3)
- IF 'PSGFD
- if '$DATA(PSJUNDC)
- WRITE $CHAR(7),$CHAR(7),!?3,"I CANNOT REINSTATE THIS ORDER! THE OLD STOP DATE IS MISSING!"
- QUIT
- +2 IF PSGFD'>PSGDT
- if $DATA(PSJUNDC)
- QUIT
- WRITE !!,"This order has technically expired as of ",$$ENDTC^PSGMI,"."
- FOR
- SET %=1
- WRITE !!,"Do you want to RENEW this order"
- DO YN^DICN
- if %
- QUIT
- Begin DoDot:1
- +3 WRITE !!?2,"This order has expired, and cannot be renewed. But the order can be",!,"reinstated. Answer 'YES' to reinstate the order now. Answer 'NO' (or '^') if",!,"you do not want to reinstate this order now."
- End DoDot:1
- +4 IF PSGFD'>PSGDT
- if %'=1
- GOTO DONE
- SET PSGRRF=0
- DO NEW^PSGOER
- DO DONE^PSGOER
- GOTO DONE
- +5 if '$DATA(PSJUNDC)
- WRITE !!,"...reinstating this order..."
- +6 ;Create a list of recipients beyond normal mail group
- +7 ; do only if from movement deletion
- if $DATA(PSJUNDC)
- Begin DoDot:1
- +8 ; Record verifying Nurse
- IF $PIECE(^PS(55,PSGP,5,+PSGORD,4),U,1)'=""
- SET PSJSENTO($JOB,$PIECE(^PS(55,PSGP,5,+PSGORD,4),U,1))=""
- +9 ; Record verifying Pharmacist
- IF $PIECE(^PS(55,PSGP,5,+PSGORD,4),U,3)'=""
- SET PSJSENTO($JOB,$PIECE(^PS(55,PSGP,5,+PSGORD,4),U,3))=""
- +10 ; Record Physician
- IF $PIECE(^PS(55,PSGP,5,+PSGORD,4),U,5)'=""
- SET PSJSENTO($JOB,$PIECE(^PS(55,PSGP,5,+PSGORD,4),U,5))=""
- +11 ; Record Provider
- IF $PIECE(^PS(55,PSGP,5,+PSGORD,0),U,2)'=""
- SET PSJSENTO($JOB,$PIECE(^PS(55,PSGP,5,+PSGORD,0),U,2))=""
- End DoDot:1
- +12 ;If a duplicate order exists do not reinstate the older one. Record in ^TMP for later advice in auto e-mail (PSJADT2)
- +13 DO NOW^%DTC
- +14 IF $DATA(PSJUNDC)
- IF $$CHECKDUP^PSGOERI(PSGP,+PSGORD)
- SET ^TMP("PSJNOTUNDC",$JOB,PSGP,PSGORD_"U")=""
- GOTO DONE
- +15 ;S DR=$S(+$P($G(^PS(55,PSGP,5,+PSGORD,4)),U,18)=1:"28///H",+$P($G(^(4)),U,26)=1:"28///H",1:"28////A")_";34////"_PSGFD_";136////@"
- +16 SET DR=$SELECT(+$PIECE($GET(^PS(55,PSGP,5,+PSGORD,4)),U,26)=1:"28///H;136////HP",+$PIECE($GET(^(4)),U,18)=1:"28///H;136////@",1:"28////A;136////@")_";34////"_PSGFD
- +17 SET Z=$GET(^PS(55,PSGP,5,+PSGORD,4))
- SET $PIECE(Z,U,11)=""
- SET $PIECE(Z,"^",15,17)="^^"
- if '$DATA(PSJUNDC)
- SET $PIECE(Z,"^",PSJSYSU,PSJSYSU+1)=DUZ_"^"_PSGDT
- SET ^(4)=Z
- WRITE "."
- +18 NEW CHKIT
- SET CHKIT=$GET(^PS(55,PSGP,5,+PSGORD,0))
- IF $PIECE(CHKIT,U,26)["P"
- IF ($PIECE(CHKIT,U,27)="R")
- SET DR=DR_";105///@;107///@"
- +19 SET DIE="^PS(55,"_PSGP_",5,"
- SET DA(1)=PSGP
- SET DA=+PSGORD
- SET PSGAL("C")=$SELECT($DATA(PSJUNDC):40,1:(PSJSYSU*10))+18500
- DO ^PSGAL5
- WRITE "."
- DO ^DIE
- WRITE "."
- +20 ;Removed cross reference after reinstate order.
- SET X=$PIECE(^PS(55,PSGP,5,+PSGORD,0),"^",20)
- SET $PIECE(^(0),"^",20)=""
- if X
- KILL ^PS(55,"AUDDD",X,PSGP,+PSGORD)
- +21 ;S X=$O(^ORD(101,"B","PS EVSEND OR",0))_";ORD(101,",PSOC="SC",PSJORDER=$$ORDER^PSJHLU(PSGORD) D EN1^XQOR:X K X
- +22 SET ^TMP("PSJUNDC",$JOB,PSGP,PSGORD_"U")=""
- +23 DO EN1^PSJHL2(PSGP,"SC",+PSGORD_"U",$SELECT($DATA(PSJUNDC):"AUTO REINSTATED",1:"REINSTATED"))
- +24 if $SELECT('$DATA(PSJUNDC)
- QUIT
- +25 SET PSGTOL=$SELECT($DATA(PSJUNDC):3,1:2)
- SET PSGUOW=$SELECT($DATA(PSJUNDC):PSJUOW,1:DUZ)
- +26 IF $DATA(^PS(53.41,1,1,+PSGUOW,1,PSGP,1,1,1,+PSGORD))
- KILL DIK,DA
- SET DIK="^PS(53.41,"_1_",1,"_+PSGUOW_",1,"_PSGP_",1,1,1,"
- SET DA=+PSGORD
- SET DA(1)=1
- SET DA(2)=PSGP
- SET DA(3)=+PSGUOW
- SET DA(4)=1
- DO ^DIK
- +27 IF '$TEST
- Begin DoDot:1
- +28 SET X=0
- if $DATA(PSJUNDC)
- SET X=$ORDER(^PS(59.6,"B",+PSGUOW,0))
- SET X=$PIECE($GET(^PS(59.6,+X,0)),U,15)
- +29 IF $SELECT(X:1,'PSJSYSL:0,PSJSYSL<3:1,1:$PIECE(^PS(55,PSGP,5,DA,4),"^",+PSJSYSU'=3+9))
- Begin DoDot:2
- +30 KILL DA
- SET DA=+PSGORD
- SET DA(1)=PSGP
- SET $PIECE(^PS(55,PSGP,5,DA,7),"^",1,2)=PSGDT_"^RE"
- SET PSGTOO=1
- SET PSGUOW=$SELECT($DATA(PSJUNDC):+PSJUOW,1:DUZ)
- DO ENL^PSGVDS
- WRITE "."
- End DoDot:2
- End DoDot:1
- +31 if '$DATA(PSJUNDC)
- WRITE ".DONE!"
- QUIT
- +32 ;
- DONE ;
- +1 KILL DA,DIE,DR,PSGAL,PSGALR,PSGFD,PSGID,PSGOD,RF,Z
- +2 QUIT
- CHECKDUP(PSGP,PSGORD) ;
- +1 NEW Z,ZZ,PSJCOM
- +2 SET FOUND=0
- +3 SET PSGX=+$GET(^PS(55,PSGP,5,+PSGORD,.2))
- SET PSJCOM=+$PIECE($GET(^(.2)),"^",8)
- +4 IF PSGX'=""
- Begin DoDot:1
- +5 FOR Z=%:0
- SET Z=$ORDER(^PS(55,+PSGP,5,"AUS",Z))
- if 'Z!FOUND
- QUIT
- Begin DoDot:2
- +6 FOR ZZ=0:0
- SET ZZ=$ORDER(^PS(55,+PSGP,5,"AUS",Z,ZZ))
- if 'ZZ!FOUND
- QUIT
- Begin DoDot:3
- +7 IF PSJCOM>0
- if +$PIECE($GET(^PS(55,+PSGP,5,ZZ,.2)),"^",8)=PSJCOM
- QUIT
- +8 IF +$GET(^PS(55,+PSGP,5,ZZ,.2))=PSGX
- Begin DoDot:4
- +9 SET FOUND=1
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +10 QUIT FOUND