- PSGOEC ;BIR/CML3-CANCEL ORDERS ;02 Mar 99 / 9:29 AM
- ;;5.0;INPATIENT MEDICATIONS ;**23,58,110,175,201,134,181,260,288,257,299,327**;16 DEC 97;Build 114
- ;
- ; Reference to ^PS(55 is supported by DBIA# 2191.
- ; Reference to ^PSSLOCK is supported by DBIA 2789.
- ;
- ENA ; all orders
- D ENCV^PSGSETU Q:$D(XQUIT) S CF=$P(PSJSYSP0,U,5) N ND,ND1 S ND="$D(^PS(55,PSGP,5,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)",ND1="$D(^PS(53.1,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)"
- F W !!,"Do you want to ",$S(CF:"discontinue",1:"mark for discontinuation")," all of this patient's orders" S %=1 D YN^DICN Q:% D ENCAM^PSGOEM
- S PSGCF=0 Q:%<0 S PSGCF=1,T=$E("T",'PSJSYSU) G:%=1 ENCA F T=0:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA I @ND Q
- E F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA I @ND1 Q
- E G DONE
- W !!,"SOME OR ALL OF THESE ORDERS HAVE" D ENUMK^PSGOEM Q:%'=1
- W !!,"...a few moments, please..." S PSGAL("C")=PSJSYSU*10+21400
- F T=PSGDT:0 S T=$O(^PS(55,PSGP,5,"AUS",T)) Q:'T F PSGDA=0:0 S PSGDA=$O(^PS(55,PSGP,5,"AUS",T,PSGDA)) Q:'PSGDA I @ND W "." D RS,^PSGAL5
- F PSGDA=0:0 S PSGDA=$O(^PS(53.1,"AC",PSGP,PSGDA)) Q:'PSGDA I @ND1 W "." D RS
- W " . . . DONE!" G DONE
- ENCA ;
- D NOW^%DTC S (Q1,PSGDT)=+$E(%,1,12) F S Q1=$O(^PS(55,PSGP,5,"AUS",Q1)) Q:'Q1 F Q2=0:0 S Q2=$O(^PS(55,PSGP,5,"AUS",Q1,Q2)) Q:'Q2 I $P($G(^PS(55,PSGP,5,Q2,0)),"^",21) Q
- E F Q2=0:0 S Q2=$O(^PS(53.1,"AC",PSGP,Q2)) Q:'Q2 I $P($G(^PS(53.1,Q2,0)),U,21) Q
- I S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0!('$$REQPROV) D G DONE
- .W !!,$C(7),"No changes made to this order." D PAUSE^VALM1
- S PSGALR=$S('$D(PSGALO):20,PSGALO?4N&($E(PSGALO)=1):10,1:20) I $P(PSJSYSP0,U,5) D ENHE^PSJADT0 S PSGOP=PSGP D ASET
- F SD=PSGDT:0 S SD=$O(^PS(55,PSGP,5,"AUS",SD)) Q:'SD F PSGORD=0:0 S PSGORD=$O(^PS(55,PSGP,5,"AUS",SD,PSGORD)) Q:'PSGORD S PSGORD=+PSGORD_"A" D AC
- D NSET S CF=$P(PSJSYSP0,U,5) F PSGORD=0:0 S PSGORD=$O(^PS(53.1,"AC",PSGP,PSGORD)) Q:'PSGORD S PSGORD=+PSGORD_"N" D NC
- W " . . . DONE!" K PSGORD G DONE
- ENO(PSGP,PSGORD) ; single order
- I PSGSTAT="D" W !,"This order has already been DISCONTINUED." D PAUSE^VALM1 Q
- S CF=$S($P(PSJSYSP0,U,5):1,PSGORD["U":0,1:($P($G(^PS(53.1,+PSGORD,0)),U,25)=""&($P($G(^(4)),U,7)=DUZ)))
- S PSJCOM=+$S(PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,.2)),"^",8),1:$P($G(^PS(53.1,+PSGORD,.2)),"^",8))
- I 'CF,PSJCOM W !!,"This order is part of a complex order and CANNOT be marked for discontinuation." Q
- I $$PNDRNOK(PSGORD) N PSJDCTYP S PSJDCTYP=$$PNDRNA(PSGORD) D:(PSJDCTYP=1!(PSJDCTYP=2)) PNDRN($G(PSJDCTYP),PSGORD) G DONE
- ;I PSJCOM W !!,"This order 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 ",$S(PSJCOM:"discontinue this series of complex orders",CF:"discontinue this order",1:"mark this order for discontinuation") S %=$S($G(PSJOCFLG):2,1:1) D YN^DICN Q:% D ENCOM^PSGOEM
- ;I %<0 S VALMBCK="" Q
- I PSJCOM W !!,"This order 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)
- I PSJCOM F W !!,"Do you want to discontinue this series of complex orders" S %=$S($G(PSJOCFLG):2,1:1) D YN^DICN Q:% D ENCOM^PSGOEM
- I 'PSJCOM,CF,'$D(PSJDCDTF) F W !!,"Do you want to discontinue this order" S %=$S($G(PSJOCFLG):2,1:1) D YN^DICN Q:% D ENCOM^PSGOEM I %<0 S VALMBCK="" Q
- I 'PSJCOM,CF,$D(PSJDCDTF) F W !!,"Enter DC to discontinue the above order or press <RETURN> to continue:" S %=$S($G(PSJOCFLG):2,1:1) D TST4DC W:%=2 !,"No action taken!" Q:% D ENDC^PSGOEM I %<0 S VALMBCK="" Q
- I 'PSJCOM,'CF,'$D(PSJDCDTF) F W !!,"Do you want mark this order for discontinuation" S %=$S($G(PSJOCFLG):2,1:1) D YN^DICN Q:% D ENCOM^PSGOEM I %<0 S VALMBCK="" Q
- G:%=1 SOC I $S(PSGORD["U":$D(^PS(55,PSGP,5,+PSGORD,4)),1:$D(^PS(53.1,+PSGORD,4))),$P(^(4),U,12) W !!,"THIS ORDER HAS"
- I D ENUMK^PSGOEM I %=1 W "..." K DA S:PSGORD["A" PSGAL("C")=PSJSYSU*10+21400,DA=+PSGORD,DA(1)=PSGP D RS,^PSGAL5:PSGORD["A" W " . . . DONE!"
- G DONE
- SOC ;
- I 'CF,'$P($S(PSGORD["U":$G(^PS(55,PSGP,5,+PSGORD,0)),1:$G(^PS(53.1,+PSGORD,0))),U,21) W !!,"...one moment, please..."
- E I CF,'($G(PSJDCTYP)=2) S PSJNOO=$$ENNOO^PSJUTL5("D") I PSJNOO<0 D ABORT^PSGOEE G DONE
- ; prompt for requesting provider
- I '($G(PSJDCTYP)=2) I CF,'$$REQPROV D ABORT^PSGOEE G DONE
- K DA D NOW^%DTC S PSGDT=%,T=$E("T",'PSJSYSU),PSGALR=20,DA=+PSGORD,DA(1)=PSGP
- I 'PSJCOM D
- .I PSGORD["U" D ASET:CF,AC
- .I PSGORD'["U" D NSET:CF,NC
- I PSJCOM N COMFLG S COMFLG=0 D
- . I PSGORD["P" Q:('$$LOCK^PSJOEA(PSGP,PSJCOM)) D
- .. N O S O="" F S O=$O(^PS(53.1,"ACX",PSJCOM,O)) Q:O="" S (PSGORD,PSJORD)=O_"P" D NSET,NC
- .I PSGORD["U" 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="" Q:COMFLG D
- .. Q:OO=PSGORD I '$$LS^PSSLOCK(DFN,OO) S COMFLG=1 Q
- I PSJCOM 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["V" S ON55=OO D D1^PSIVOPT2 S PSIVALT=1,PSIVALCK="STOP",PSIVREA="D",ON=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3) D
- .. D LOG^PSIVORAL N PSJORD S PSJORD=ON55,P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),P("NAT")=PSJNOO D HL^PSIVORA
- . I OO["U" N PSGORD,PSJORD S (PSGORD,PSJORD)=OO D ASET^PSGOEC,AC^PSGOEC
- K:+$$ISCLOZ^PSJCLOZ(,,,,$G(PSGDN)) ^XTMP("PSJ4D-"_DFN) ;p357 clear clozapine 4-day supply
- Q
- D1 N %,DA,DIE,DIU,STP,NSTOP
- D NOW^%DTC S NSTOP=+$E(%,1,12),STP=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),NSTOP=+$S(STP>NSTOP:NSTOP,1:STP),P(17)="D"
- S DA(1)=DFN,DA=+ON55,DIE="^PS(55,"_DFN_",""IV"",",DR="109////"_NSTOP_$S('$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7):";116////"_STP,1:"")_";100///D;.03////"_NSTOP,PSIVACT=1 D ^DIE
- I $S($G(PSIVAC)="OD":0,$G(PSIVAC)'="AD":1,$G(PSGALO)<1060:0,1:$P($G(PSJSYSW0),U,15)) S X=$S($G(PSIVAC)="AD":1,1:2) D ENLBL^PSIVOPT(X,$S(X=1:+$G(PSGUOW),1:DUZ),DFN,3,+ON55,$E("AD",1,3-X))
- D:'$D(PSJIVORF) ORPARM^PSIVOREN Q:'PSJIVORF ;* S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'ORIFN
- Q
- OUT ;
- W $S(PSJCOM:"...ORDER ",1:"...ORDERS "),$S(CF:"DISCONTINUED!",1:"MARKED!") S PSGCANFL=1
- DONE ;
- K CF,DA,DIE,DP,DR,ORIFN,ORETURN,PSGAL,PSGALR,PSGDA,SD,ST,T,UCF,Y,PSJDCTYP Q
- ASET ;
- S DIE="^PS(55,"_PSGP_",5,",DR="136////@;28////"_$S($P($G(^PS(55,PSGP,5,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_";Q;34////"_PSGDT_$S(T]"":";49////1",1:"")
- Q
- NSET ;
- S DIE="^PS(53.1,",DR="28////"_$S($P($G(^PS(53.1,+$G(PSJORD),0)),U,27)="E":"DE",$D(PSGEDIT):"DE",1:"D")_$S(T]"":";42////1",1:"")_";25////"_PSGDT Q
- AC ;
- I 'CF K DA S $P(^PS(55,PSGP,5,+PSGORD,4),U,11,14)="^1^"_DUZ_U_PSGDT,PSGAL("C")=13040,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5
- I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"A",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
- Q:'CF K DA,ORIFN S PSGAL("C")=PSJSYSU*10+4000,DA=+PSGORD,DA(1)=PSGP D ^PSGAL5 S $P(^(2),U,3)=$P(^PS(55,PSGP,5,+PSGORD,2),U,4) D ^DIE S ^PS(55,"AUE",PSGP,+PSGORD)=""
- I '$D(PSJSYSL) S PSJSYSL=""
- I PSJSYSL K DA S $P(^PS(55,PSGP,5,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOL=2,PSGUOW=DUZ,PSGTOO=1,DA=+PSGORD,DA(1)=PSGP D ENL^PSGVDS
- S ORIFN=$P($G(^PS(55,PSGP,5,+PSGORD,0)),U,21) D:ORIFN DCOR^PSGOECS
- Q
- NC ;
- D KILL531^PSJIMO1(PSGP,"",+PSGORD)
- I 'CF S $P(^PS(53.1,+PSGORD,4),"^",11,14)="^1^"_DUZ_U_PSGDT
- I 'CF,$D(PSJSYSO) S PSGORD=+PSGORD_"N",PSGPOSA="C",PSGPOSD=PSGDT D ENPOS^PSGVDS
- Q:'CF S PSGSTAT=$P($G(^PS(53.1,+PSGORD,0)),U,9),PSGORIFN=$P($G(^(0)),U,21)
- I PSGSTAT'="U" K DA,ORIFN S DA=+PSGORD D ^DIE I PSJSYSL,PSJSYSL<3,(PSGSTAT'="P") S $P(^PS(53.1,+PSGORD,7),U,1,2)=PSGDT_U_$S($D(PSGEDIT):"DE",1:"D"),PSGTOO=2,PSGUOW=DUZ,PSGTOL=2 D ENL^PSGVDS
- I PSGSTAT="U" K DA S DA=+PSGORD,DIK="^PS(53.1," D ^DIK
- I PSGORIFN S ORIFN=PSGORIFN D DCOR^PSGOECS
- Q
- T ;
- F W !!,"Is this due to the patient being transferred" S %=2 D YN^DICN Q:% D ENCTM^PSGOEM1
- S T=$S(%<0:"^",1:$E("T",%=1)) Q
- RS ;
- ; naked ref below is from variable ND1, ^PS(53.1,PSGDA,4)
- S $P(^(4),U,11,14)="^^^" Q
- ;
- REQPROV() ;
- I $G(PSJDCTYP)=2 Q 1
- K PSJDCPRV,DIC,DUOUT,DTOUT,Y
- N PROVIDER,PROVNAME,RESULT,RSB S RESULT=0
- S PROVIDER=+$P($G(^PS(55,DFN,5.1)),"^",2),PROVNAME=""
- I PROVIDER>0 D
- .S DIC=200,DR="53.1;53.4",DIQ="RSB",DIQ(0)="I",DA=PROVIDER D EN^DIQ1
- .K DIC,DR,DA,DIQ
- .I $G(RSB(200,PROVIDER,53.1,"I"))="1"&(($G(RSB(200,PROVIDER,53.4,"I"))="")!($G(RSB(200,PROVIDER,53.4,"I"))>DT)) D
- ..S DIC=200,DA=PROVIDER,DR=".01",DIQ="RSB",DIQ(0)="E" D EN^DIQ1
- ..S PROVNAME=$G(RSB(200,PROVIDER,.01,"E")) K DA,DIQ,DR
- K DIC S DIC=200,DIC(0)="AEMQZ"
- S:PROVNAME]"" DIC("B")=PROVNAME
- S DIC("A")="Requesting PROVIDER: "
- S DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)" D ^DIC K DIC
- I +Y>0,'$D(DUOUT),'$D(DTOUT) S RESULT=1,PSJDCPRV=+Y
- Q RESULT
- ;
- PNDRNA(ORDER) ; Ask Discontinue Pending Renewal only, or both Pending Renew and Renewed Order
- ; Perform this action only for pending renewals
- I '$G(ORDER)!'($G(ORDER)["P") Q 3
- ; Quit if original order is no longer active
- N ORIGORD,ORIGSTOP S ORIGORD=$P($G(^PS(53.1,+ORDER,0)),"^",25) Q:'ORIGORD D I ORIGSTOP<$G(PSGDT) Q 1
- .S ORIGSTOP=$S(ORIGORD["U":$P($G(^PS(55,PSGP,5,+ORIGORD,2)),"^",4),ORIGORD["V":$P($G(^PS(55,PSGP,"IV",+ORIGORD,0)),"^",3),1:"")
- N NDP2
- S NDP2=^PS(53.1,+ORDER,.2) S DRG=NDP2,DO=$P(DRG,"^",2) S DRG=$$ENPDN^PSGMI($P(DRG,"^"))
- S ND2=^PS(53.1,+ORDER,2) S SCH=$P(ND2,"^"),START=$P(ND2,"^",2),START=$$FMTE^XLFDT(START,2)
- W !!?5,DRG_" "_DO
- W !?5,"This order has a pending status. If this pending order"
- W !?5,"is discontinued, the original order may still be active."
- S DIR("A")="Select order(s) to discontinue"
- S DIR(0)="S^1:DC BOTH Orders;2:DC Pending Order;3:Cancel - No Action Taken"
- S DIR("L",1)="1 - DC BOTH Orders"
- S DIR("L",2)="2 - DC Pending Order"
- S DIR("L",3)="3 - Cancel - No Action Taken" D ^DIR
- ; Reverse order - Y=1 - Pending only Y=2:BOTH
- S Y=$S(Y=1:2,Y=2:1,1:3)
- Q Y
- ;
- PNDRN(PSJDCTYP,ORDER) ; Perform Discontinue action for Pending order only or both Pending and Renewed
- ; Perform this action only for pending renewals
- N PSGORD S PSGORD=ORDER
- Q:'$G(PSGORD)!'($G(PSGORD)["P")
- I PSJDCTYP=1 G SOC
- I PSJDCTYP=2 S PSJDCTYP=1 D SOC 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 SOC K PSJDCTYP
- Q
- ;
- PNDRNOK(ORDER) ; Execute DC Pending Renew enhancement only if
- ; 1) Renewal order is pending/non-verified, and
- ; 2) Original order is not DC'd or Expired
- Q:'$G(PSGORD)!'($G(PSGORD)["P") 0
- N ORIGORD,ORIGSTOP S ORIGORD=$P($G(^PS(53.1,+ORDER,0)),"^",25) Q:'ORIGORD 0 D I ORIGSTOP<$G(PSGDT) Q 0
- .S ORIGSTOP=$S(ORIGORD["U":$P($G(^PS(55,PSGP,5,+ORIGORD,2)),"^",4),ORIGORD["V":$P($G(^PS(55,PSGP,"IV",+ORIGORD,0)),"^",3),1:"")
- Q:'($P($G(^PS(53.1,+PSGORD,0)),U,24)="R") 0
- Q 1
- ;
- TST4DC ; Test for DC at prompt
- R X:$S($D(DTIME):DTIME,1:300) I '$T S %=2 Q
- S %=$S(X="DC":1,X="Dc":1,X="dc":1,X="dC":1,X="D":1,X="d":1,X="":2,X="^":2,X]"":"",1:2)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGOEC 11267 printed Jan 18, 2025@03:03:18 Page 2
- PSGOEC ;BIR/CML3-CANCEL ORDERS ;02 Mar 99 / 9:29 AM
- +1 ;;5.0;INPATIENT MEDICATIONS ;**23,58,110,175,201,134,181,260,288,257,299,327**;16 DEC 97;Build 114
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA# 2191.
- +4 ; Reference to ^PSSLOCK is supported by DBIA 2789.
- +5 ;
- ENA ; all orders
- +1 DO ENCV^PSGSETU
- if $DATA(XQUIT)
- QUIT
- SET CF=$PIECE(PSJSYSP0,U,5)
- NEW ND,ND1
- SET ND="$D(^PS(55,PSGP,5,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)"
- SET ND1="$D(^PS(53.1,PSGDA,4)),$P(^(4),U,12),$P(^(4),U,13)"
- +2 FOR
- WRITE !!,"Do you want to ",$SELECT(CF:"discontinue",1:"mark for discontinuation")," all of this patient's orders"
- SET %=1
- DO YN^DICN
- if %
- QUIT
- DO ENCAM^PSGOEM
- +3 SET PSGCF=0
- if %<0
- QUIT
- SET PSGCF=1
- SET T=$EXTRACT("T",'PSJSYSU)
- if %=1
- GOTO ENCA
- FOR T=0:0
- SET T=$ORDER(^PS(55,PSGP,5,"AUS",T))
- if 'T
- QUIT
- FOR PSGDA=0:0
- SET PSGDA=$ORDER(^PS(55,PSGP,5,"AUS",T,PSGDA))
- if 'PSGDA
- QUIT
- IF @ND
- QUIT
- +4 IF '$TEST
- FOR PSGDA=0:0
- SET PSGDA=$ORDER(^PS(53.1,"AC",PSGP,PSGDA))
- if 'PSGDA
- QUIT
- IF @ND1
- QUIT
- +5 IF '$TEST
- GOTO DONE
- +6 WRITE !!,"SOME OR ALL OF THESE ORDERS HAVE"
- DO ENUMK^PSGOEM
- if %'=1
- QUIT
- +7 WRITE !!,"...a few moments, please..."
- SET PSGAL("C")=PSJSYSU*10+21400
- +8 FOR T=PSGDT:0
- SET T=$ORDER(^PS(55,PSGP,5,"AUS",T))
- if 'T
- QUIT
- FOR PSGDA=0:0
- SET PSGDA=$ORDER(^PS(55,PSGP,5,"AUS",T,PSGDA))
- if 'PSGDA
- QUIT
- IF @ND
- WRITE "."
- DO RS
- DO ^PSGAL5
- +9 FOR PSGDA=0:0
- SET PSGDA=$ORDER(^PS(53.1,"AC",PSGP,PSGDA))
- if 'PSGDA
- QUIT
- IF @ND1
- WRITE "."
- DO RS
- +10 WRITE " . . . DONE!"
- GOTO DONE
- ENCA ;
- +1 DO NOW^%DTC
- SET (Q1,PSGDT)=+$EXTRACT(%,1,12)
- FOR
- SET Q1=$ORDER(^PS(55,PSGP,5,"AUS",Q1))
- if 'Q1
- QUIT
- FOR Q2=0:0
- SET Q2=$ORDER(^PS(55,PSGP,5,"AUS",Q1,Q2))
- if 'Q2
- QUIT
- IF $PIECE($GET(^PS(55,PSGP,5,Q2,0)),"^",21)
- QUIT
- +2 IF '$TEST
- FOR Q2=0:0
- SET Q2=$ORDER(^PS(53.1,"AC",PSGP,Q2))
- if 'Q2
- QUIT
- IF $PIECE($GET(^PS(53.1,Q2,0)),U,21)
- QUIT
- +3 IF $TEST
- SET PSJNOO=$$ENNOO^PSJUTL5("D")
- IF PSJNOO<0!('$$REQPROV)
- Begin DoDot:1
- +4 WRITE !!,$CHAR(7),"No changes made to this order."
- DO PAUSE^VALM1
- End DoDot:1
- GOTO DONE
- +5 SET PSGALR=$SELECT('$DATA(PSGALO):20,PSGALO?4N&($EXTRACT(PSGALO)=1):10,1:20)
- IF $PIECE(PSJSYSP0,U,5)
- DO ENHE^PSJADT0
- SET PSGOP=PSGP
- DO ASET
- +6 FOR SD=PSGDT:0
- SET SD=$ORDER(^PS(55,PSGP,5,"AUS",SD))
- if 'SD
- QUIT
- FOR PSGORD=0:0
- SET PSGORD=$ORDER(^PS(55,PSGP,5,"AUS",SD,PSGORD))
- if 'PSGORD
- QUIT
- SET PSGORD=+PSGORD_"A"
- DO AC
- +7 DO NSET
- SET CF=$PIECE(PSJSYSP0,U,5)
- FOR PSGORD=0:0
- SET PSGORD=$ORDER(^PS(53.1,"AC",PSGP,PSGORD))
- if 'PSGORD
- QUIT
- SET PSGORD=+PSGORD_"N"
- DO NC
- +8 WRITE " . . . DONE!"
- KILL PSGORD
- GOTO DONE
- ENO(PSGP,PSGORD) ; single order
- +1 IF PSGSTAT="D"
- WRITE !,"This order has already been DISCONTINUED."
- DO PAUSE^VALM1
- QUIT
- +2 SET CF=$SELECT($PIECE(PSJSYSP0,U,5):1,PSGORD["U":0,1:($PIECE($GET(^PS(53.1,+PSGORD,0)),U,25)=""&($PIECE($GET(^(4)),U,7)=DUZ)))
- +3 SET PSJCOM=+$SELECT(PSGORD["U":$PIECE($GET(^PS(55,PSGP,5,+PSGORD,.2)),"^",8),1:$PIECE($GET(^PS(53.1,+PSGORD,.2)),"^",8))
- +4 IF 'CF
- IF PSJCOM
- WRITE !!,"This order is part of a complex order and CANNOT be marked for discontinuation."
- QUIT
- +5 IF $$PNDRNOK(PSGORD)
- NEW PSJDCTYP
- SET PSJDCTYP=$$PNDRNA(PSGORD)
- if (PSJDCTYP=1!(PSJDCTYP=2))
- DO PNDRN($GET(PSJDCTYP),PSGORD)
- GOTO DONE
- +6 ;I PSJCOM W !!,"This order 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)
- +7 ;F W !!,"Do you want to ",$S(PSJCOM:"discontinue this series of complex orders",CF:"discontinue this order",1:"mark this order for discontinuation") S %=$S($G(PSJOCFLG):2,1:1) D YN^DICN Q:% D ENCOM^PSGOEM
- +8 ;I %<0 S VALMBCK="" Q
- +9 IF PSJCOM
- WRITE !!,"This order 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)
- +10 IF PSJCOM
- FOR
- WRITE !!,"Do you want to discontinue this series of complex orders"
- SET %=$SELECT($GET(PSJOCFLG):2,1:1)
- DO YN^DICN
- if %
- QUIT
- DO ENCOM^PSGOEM
- +11 IF 'PSJCOM
- IF CF
- IF '$DATA(PSJDCDTF)
- FOR
- WRITE !!,"Do you want to discontinue this order"
- SET %=$SELECT($GET(PSJOCFLG):2,1:1)
- DO YN^DICN
- if %
- QUIT
- DO ENCOM^PSGOEM
- IF %<0
- SET VALMBCK=""
- QUIT
- +12 IF 'PSJCOM
- IF CF
- IF $DATA(PSJDCDTF)
- FOR
- WRITE !!,"Enter DC to discontinue the above order or press <RETURN> to continue:"
- SET %=$SELECT($GET(PSJOCFLG):2,1:1)
- DO TST4DC
- if %=2
- WRITE !,"No action taken!"
- if %
- QUIT
- DO ENDC^PSGOEM
- IF %<0
- SET VALMBCK=""
- QUIT
- +13 IF 'PSJCOM
- IF 'CF
- IF '$DATA(PSJDCDTF)
- FOR
- WRITE !!,"Do you want mark this order for discontinuation"
- SET %=$SELECT($GET(PSJOCFLG):2,1:1)
- DO YN^DICN
- if %
- QUIT
- DO ENCOM^PSGOEM
- IF %<0
- SET VALMBCK=""
- QUIT
- +14 if %=1
- GOTO SOC
- IF $SELECT(PSGORD["U":$DATA(^PS(55,PSGP,5,+PSGORD,4)),1:$DATA(^PS(53.1,+PSGORD,4)))
- IF $PIECE(^(4),U,12)
- WRITE !!,"THIS ORDER HAS"
- +15 IF $TEST
- DO ENUMK^PSGOEM
- IF %=1
- WRITE "..."
- KILL DA
- if PSGORD["A"
- SET PSGAL("C")=PSJSYSU*10+21400
- SET DA=+PSGORD
- SET DA(1)=PSGP
- DO RS
- if PSGORD["A"
- DO ^PSGAL5
- WRITE " . . . DONE!"
- +16 GOTO DONE
- SOC ;
- +1 IF 'CF
- IF '$PIECE($SELECT(PSGORD["U":$GET(^PS(55,PSGP,5,+PSGORD,0)),1:$GET(^PS(53.1,+PSGORD,0))),U,21)
- WRITE !!,"...one moment, please..."
- +2 IF '$TEST
- IF CF
- IF '($GET(PSJDCTYP)=2)
- SET PSJNOO=$$ENNOO^PSJUTL5("D")
- IF PSJNOO<0
- DO ABORT^PSGOEE
- GOTO DONE
- +3 ; prompt for requesting provider
- +4 IF '($GET(PSJDCTYP)=2)
- IF CF
- IF '$$REQPROV
- DO ABORT^PSGOEE
- GOTO DONE
- +5 KILL DA
- DO NOW^%DTC
- SET PSGDT=%
- SET T=$EXTRACT("T",'PSJSYSU)
- SET PSGALR=20
- SET DA=+PSGORD
- SET DA(1)=PSGP
- +6 IF 'PSJCOM
- Begin DoDot:1
- +7 IF PSGORD["U"
- if CF
- DO ASET
- DO AC
- +8 IF PSGORD'["U"
- if CF
- DO NSET
- DO NC
- End DoDot:1
- +9 IF PSJCOM
- NEW COMFLG
- SET COMFLG=0
- Begin DoDot:1
- +10 IF PSGORD["P"
- if ('$$LOCK^PSJOEA(PSGP,PSJCOM))
- QUIT
- Begin DoDot:2
- +11 NEW O
- SET O=""
- FOR
- SET O=$ORDER(^PS(53.1,"ACX",PSJCOM,O))
- if O=""
- QUIT
- SET (PSGORD,PSJORD)=O_"P"
- DO NSET
- DO NC
- End DoDot:2
- +12 IF PSGORD["U"
- 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
- if COMFLG
- QUIT
- Begin DoDot:2
- +13 if OO=PSGORD
- QUIT
- IF '$$LS^PSSLOCK(DFN,OO)
- SET COMFLG=1
- QUIT
- End DoDot:2
- End DoDot:1
- +14 IF PSJCOM
- if COMFLG
- QUIT
- 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["V"
- SET ON55=OO
- DO D1^PSIVOPT2
- SET PSIVALT=1
- SET PSIVALCK="STOP"
- SET PSIVREA="D"
- SET ON=ON55
- SET P(3)=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,3)
- Begin DoDot:2
- +16 DO LOG^PSIVORAL
- NEW PSJORD
- SET PSJORD=ON55
- SET P(3)=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,3)
- SET P("NAT")=PSJNOO
- DO HL^PSIVORA
- End DoDot:2
- +17 IF OO["U"
- NEW PSGORD,PSJORD
- SET (PSGORD,PSJORD)=OO
- DO ASET^PSGOEC
- DO AC^PSGOEC
- End DoDot:1
- +18 ;p357 clear clozapine 4-day supply
- if +$$ISCLOZ^PSJCLOZ(,,,,$GET(PSGDN))
- KILL ^XTMP("PSJ4D-"_DFN)
- +19 QUIT
- D1 NEW %,DA,DIE,DIU,STP,NSTOP
- +1 DO NOW^%DTC
- SET NSTOP=+$EXTRACT(%,1,12)
- SET STP=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,3)
- SET NSTOP=+$SELECT(STP>NSTOP:NSTOP,1:STP)
- SET P(17)="D"
- +2 SET DA(1)=DFN
- SET DA=+ON55
- SET DIE="^PS(55,"_DFN_",""IV"","
- SET DR="109////"_NSTOP_$SELECT('$PIECE($GET(^PS(55,DFN,"IV",+ON55,2)),U,7):";116////"_STP,1:"")_";100///D;.03////"_NSTOP
- SET PSIVACT=1
- DO ^DIE
- +3 IF $SELECT($GET(PSIVAC)="OD":0,$GET(PSIVAC)'="AD":1,$GET(PSGALO)<1060:0,1:$PIECE($GET(PSJSYSW0),U,15))
- SET X=$SELECT($GET(PSIVAC)="AD":1,1:2)
- DO ENLBL^PSIVOPT(X,$SELECT(X=1:+$GET(PSGUOW),1:DUZ),DFN,3,+ON55,$EXTRACT("AD",1,3-X))
- +4 ;* S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'ORIFN
- if '$DATA(PSJIVORF)
- DO ORPARM^PSIVOREN
- if 'PSJIVORF
- QUIT
- +5 QUIT
- OUT ;
- +1 WRITE $SELECT(PSJCOM:"...ORDER ",1:"...ORDERS "),$SELECT(CF:"DISCONTINUED!",1:"MARKED!")
- SET PSGCANFL=1
- DONE ;
- +1 KILL CF,DA,DIE,DP,DR,ORIFN,ORETURN,PSGAL,PSGALR,PSGDA,SD,ST,T,UCF,Y,PSJDCTYP
- QUIT
- ASET ;
- +1 SET DIE="^PS(55,"_PSGP_",5,"
- SET DR="136////@;28////"_$SELECT($PIECE($GET(^PS(55,PSGP,5,+$GET(PSJORD),0)),U,27)="E":"DE",$DATA(PSGEDIT):"DE",1:"D")_";Q;34////"_PSGDT_$SELECT(T]"":";49////1",1:"")
- +2 QUIT
- NSET ;
- +1 SET DIE="^PS(53.1,"
- SET DR="28////"_$SELECT($PIECE($GET(^PS(53.1,+$GET(PSJORD),0)),U,27)="E":"DE",$DATA(PSGEDIT):"DE",1:"D")_$SELECT(T]"":";42////1",1:"")_";25////"_PSGDT
- QUIT
- AC ;
- +1 IF 'CF
- KILL DA
- SET $PIECE(^PS(55,PSGP,5,+PSGORD,4),U,11,14)="^1^"_DUZ_U_PSGDT
- SET PSGAL("C")=13040
- SET DA=+PSGORD
- SET DA(1)=PSGP
- DO ^PSGAL5
- +2 IF 'CF
- IF $DATA(PSJSYSO)
- SET PSGORD=+PSGORD_"A"
- SET PSGPOSA="C"
- SET PSGPOSD=PSGDT
- DO ENPOS^PSGVDS
- +3 if 'CF
- QUIT
- KILL DA,ORIFN
- SET PSGAL("C")=PSJSYSU*10+4000
- SET DA=+PSGORD
- SET DA(1)=PSGP
- DO ^PSGAL5
- SET $PIECE(^(2),U,3)=$PIECE(^PS(55,PSGP,5,+PSGORD,2),U,4)
- DO ^DIE
- SET ^PS(55,"AUE",PSGP,+PSGORD)=""
- +4 IF '$DATA(PSJSYSL)
- SET PSJSYSL=""
- +5 IF PSJSYSL
- KILL DA
- SET $PIECE(^PS(55,PSGP,5,+PSGORD,7),U,1,2)=PSGDT_U_$SELECT($DATA(PSGEDIT):"DE",1:"D")
- SET PSGTOL=2
- SET PSGUOW=DUZ
- SET PSGTOO=1
- SET DA=+PSGORD
- SET DA(1)=PSGP
- DO ENL^PSGVDS
- +6 SET ORIFN=$PIECE($GET(^PS(55,PSGP,5,+PSGORD,0)),U,21)
- if ORIFN
- DO DCOR^PSGOECS
- +7 QUIT
- NC ;
- +1 DO KILL531^PSJIMO1(PSGP,"",+PSGORD)
- +2 IF 'CF
- SET $PIECE(^PS(53.1,+PSGORD,4),"^",11,14)="^1^"_DUZ_U_PSGDT
- +3 IF 'CF
- IF $DATA(PSJSYSO)
- SET PSGORD=+PSGORD_"N"
- SET PSGPOSA="C"
- SET PSGPOSD=PSGDT
- DO ENPOS^PSGVDS
- +4 if 'CF
- QUIT
- SET PSGSTAT=$PIECE($GET(^PS(53.1,+PSGORD,0)),U,9)
- SET PSGORIFN=$PIECE($GET(^(0)),U,21)
- +5 IF PSGSTAT'="U"
- KILL DA,ORIFN
- SET DA=+PSGORD
- DO ^DIE
- IF PSJSYSL
- IF PSJSYSL<3
- IF (PSGSTAT'="P")
- SET $PIECE(^PS(53.1,+PSGORD,7),U,1,2)=PSGDT_U_$SELECT($DATA(PSGEDIT):"DE",1:"D")
- SET PSGTOO=2
- SET PSGUOW=DUZ
- SET PSGTOL=2
- DO ENL^PSGVDS
- +6 IF PSGSTAT="U"
- KILL DA
- SET DA=+PSGORD
- SET DIK="^PS(53.1,"
- DO ^DIK
- +7 IF PSGORIFN
- SET ORIFN=PSGORIFN
- DO DCOR^PSGOECS
- +8 QUIT
- T ;
- +1 FOR
- WRITE !!,"Is this due to the patient being transferred"
- SET %=2
- DO YN^DICN
- if %
- QUIT
- DO ENCTM^PSGOEM1
- +2 SET T=$SELECT(%<0:"^",1:$EXTRACT("T",%=1))
- QUIT
- RS ;
- +1 ; naked ref below is from variable ND1, ^PS(53.1,PSGDA,4)
- +2 SET $PIECE(^(4),U,11,14)="^^^"
- QUIT
- +3 ;
- REQPROV() ;
- +1 IF $GET(PSJDCTYP)=2
- QUIT 1
- +2 KILL PSJDCPRV,DIC,DUOUT,DTOUT,Y
- +3 NEW PROVIDER,PROVNAME,RESULT,RSB
- SET RESULT=0
- +4 SET PROVIDER=+$PIECE($GET(^PS(55,DFN,5.1)),"^",2)
- SET PROVNAME=""
- +5 IF PROVIDER>0
- Begin DoDot:1
- +6 SET DIC=200
- SET DR="53.1;53.4"
- SET DIQ="RSB"
- SET DIQ(0)="I"
- SET DA=PROVIDER
- DO EN^DIQ1
- +7 KILL DIC,DR,DA,DIQ
- +8 IF $GET(RSB(200,PROVIDER,53.1,"I"))="1"&(($GET(RSB(200,PROVIDER,53.4,"I"))="")!($GET(RSB(200,PROVIDER,53.4,"I"))>DT))
- Begin DoDot:2
- +9 SET DIC=200
- SET DA=PROVIDER
- SET DR=".01"
- SET DIQ="RSB"
- SET DIQ(0)="E"
- DO EN^DIQ1
- +10 SET PROVNAME=$GET(RSB(200,PROVIDER,.01,"E"))
- KILL DA,DIQ,DR
- End DoDot:2
- End DoDot:1
- +11 KILL DIC
- SET DIC=200
- SET DIC(0)="AEMQZ"
- +12 if PROVNAME]""
- SET DIC("B")=PROVNAME
- +13 SET DIC("A")="Requesting PROVIDER: "
- +14 SET DIC("S")="I $D(^(""PS"")),^(""PS""),$S('$P(^(""PS""),""^"",4):1,1:$P(^(""PS""),""^"",4)>DT)"
- DO ^DIC
- KILL DIC
- +15 IF +Y>0
- IF '$DATA(DUOUT)
- IF '$DATA(DTOUT)
- SET RESULT=1
- SET PSJDCPRV=+Y
- +16 QUIT RESULT
- +17 ;
- PNDRNA(ORDER) ; Ask Discontinue Pending Renewal only, or both Pending Renew and Renewed Order
- +1 ; Perform this action only for pending renewals
- +2 IF '$GET(ORDER)!'($GET(ORDER)["P")
- QUIT 3
- +3 ; Quit if original order is no longer active
- +4 NEW ORIGORD,ORIGSTOP
- SET ORIGORD=$PIECE($GET(^PS(53.1,+ORDER,0)),"^",25)
- if 'ORIGORD
- QUIT
- Begin DoDot:1
- +5 SET ORIGSTOP=$SELECT(ORIGORD["U":$PIECE($GET(^PS(55,PSGP,5,+ORIGORD,2)),"^",4),ORIGORD["V":$PIECE($GET(^PS(55,PSGP,"IV",+ORIGORD,0)),"^",3),1:"")
- End DoDot:1
- IF ORIGSTOP<$GET(PSGDT)
- QUIT 1
- +6 NEW NDP2
- +7 SET NDP2=^PS(53.1,+ORDER,.2)
- SET DRG=NDP2
- SET DO=$PIECE(DRG,"^",2)
- SET DRG=$$ENPDN^PSGMI($PIECE(DRG,"^"))
- +8 SET ND2=^PS(53.1,+ORDER,2)
- SET SCH=$PIECE(ND2,"^")
- SET START=$PIECE(ND2,"^",2)
- SET START=$$FMTE^XLFDT(START,2)
- +9 WRITE !!?5,DRG_" "_DO
- +10 WRITE !?5,"This order has a pending status. If this pending order"
- +11 WRITE !?5,"is discontinued, the original order may still be active."
- +12 SET DIR("A")="Select order(s) to discontinue"
- +13 SET DIR(0)="S^1:DC BOTH Orders;2:DC Pending Order;3:Cancel - No Action Taken"
- +14 SET DIR("L",1)="1 - DC BOTH Orders"
- +15 SET DIR("L",2)="2 - DC Pending Order"
- +16 SET DIR("L",3)="3 - Cancel - No Action Taken"
- DO ^DIR
- +17 ; Reverse order - Y=1 - Pending only Y=2:BOTH
- +18 SET Y=$SELECT(Y=1:2,Y=2:1,1:3)
- +19 QUIT Y
- +20 ;
- PNDRN(PSJDCTYP,ORDER) ; Perform Discontinue action for Pending order only or both Pending and Renewed
- +1 ; Perform this action only for pending renewals
- +2 NEW PSGORD
- SET PSGORD=ORDER
- +3 if '$GET(PSGORD)!'($GET(PSGORD)["P")
- QUIT
- +4 IF PSJDCTYP=1
- GOTO SOC
- +5 IF PSJDCTYP=2
- SET PSJDCTYP=1
- DO SOC
- if '$GET(PSJDCTYP)
- QUIT
- Begin DoDot:1
- +6 IF ($GET(PSJNOO)<0)
- QUIT
- +7 NEW ND5310
- SET ND5310=$GET(^PS(53.1,+PSGORD,0))
- +8 NEW PSGORD
- SET PSGORD=$PIECE(ND5310,"^",25)
- IF PSGORD
- SET PSJDCTYP=2
- DO SOC
- KILL PSJDCTYP
- End DoDot:1
- +9 QUIT
- +10 ;
- PNDRNOK(ORDER) ; Execute DC Pending Renew enhancement only if
- +1 ; 1) Renewal order is pending/non-verified, and
- +2 ; 2) Original order is not DC'd or Expired
- +3 if '$GET(PSGORD)!'($GET(PSGORD)["P")
- QUIT 0
- +4 NEW ORIGORD,ORIGSTOP
- SET ORIGORD=$PIECE($GET(^PS(53.1,+ORDER,0)),"^",25)
- if 'ORIGORD
- QUIT 0
- Begin DoDot:1
- +5 SET ORIGSTOP=$SELECT(ORIGORD["U":$PIECE($GET(^PS(55,PSGP,5,+ORIGORD,2)),"^",4),ORIGORD["V":$PIECE($GET(^PS(55,PSGP,"IV",+ORIGORD,0)),"^",3),1:"")
- End DoDot:1
- IF ORIGSTOP<$GET(PSGDT)
- QUIT 0
- +6 if '($PIECE($GET(^PS(53.1,+PSGORD,0)),U,24)="R")
- QUIT 0
- +7 QUIT 1
- +8 ;
- TST4DC ; Test for DC at prompt
- +1 READ X:$SELECT($DATA(DTIME):DTIME,1:300)
- IF '$TEST
- SET %=2
- QUIT
- +2 SET %=$SELECT(X="DC":1,X="Dc":1,X="dc":1,X="dC":1,X="D":1,X="d":1,X="":2,X="^":2,X]"":"",1:2)
- +3 QUIT