- PSIVOPT2 ;BIR/PR,MLM-OPTION DRIVER (CONT) ;02 Mar 99 / 9:27 AM
- ;;5.0;INPATIENT MEDICATIONS ;**23,29,58,110,127,133,135,157,181,258,287,374**;16 DEC 97;Build 2
- ;
- ; Reference to ^PS(55 is supported by DBIA# 2191.
- ; Reference to ^PSSLOCK is supported by DBIA #2789
- ;
- D ; Discontinue order.
- D NATURE^PSIVOREN I '$D(P("NAT")) W !,$C(7),"Order Unchanged." S COMQUIT=1 Q
- ;* 8/2* D EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED"),D1
- I '$$REQPROV^PSGOEC W !,$C(7),"Order Unchanged." S (COMQUIT,PROVQUIT)=1 Q
- I 'PSJCOM D
- .D D1
- .S PSIVALT=1,PSIVALCK="STOP",PSIVREA="D",ON=ON55 D LOG^PSIVORAL S P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3)
- I PSJCOM N COMFLG S COMFLG=0 D
- .I ON55'["P" N COMFLG,O,OO S (COMFLG,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=ON55 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 S PSIVALT=1,PSIVALCK="STOP",PSIVREA="D",ON=ON55 D LOG^PSIVORAL N PSJORD S P(3)=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),PSJORD=ON55 D HL^PSIVORA Q
- .I OO["U" N PSGORD,PSJORD,PSJNOO K DA D NOW^%DTC S PSGDT=%,T=$E("T",'PSJSYSU),PSGALR=20,PSGP=DFN,DA=+OO,DA(1)=PSGP,(PSGORD,PSJORD)=OO,PSJNOO=P("NAT") D
- ..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))) D ASET^PSGOEC,AC^PSGOEC
- Q
- D1 N %,DA,DIE,DIU,STP,NSTOP
- S NSTOP=$$DATE^PSJUTL2(),STP=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3),NSTOP=+$S(STP>NSTOP:NSTOP,1:STP),P(17)="D"
- K TMP
- S TMP(55.01,""_+ON55_","_DFN_","_"",109)=NSTOP
- S:'$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7) TMP(55.01,""_+ON55_","_DFN_","_"",116)=STP
- S TMP(55.01,""_+ON55_","_DFN_","_"",100)="D"
- S TMP(55.01,""_+ON55_","_DFN_","_"",157)=""
- S TMP(55.01,""_+ON55_","_DFN_","_"",.03)=NSTOP
- S PSIVACT=1
- D FILE^DIE("","TMP")
- K TMP
- 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
- ;
- R ; Renew order.
- ;I PSJCOM D RIV^PSJCOMR Q
- I PSJCOM D ^PSJCOMR Q
- I P(17)="D",P(12) N ERR D RI W:$G(ERR)=1 $C(7)," Order unchanged." I $G(ERR)<2 S COMQUIT=1 Q
- I $G(PSGORQF) S COMQUIT=1 Q
- ;PSJOCFLG is killed of after the OC is performed. The Dosing is still need to trigger(again) if the
- ; user said "no" at OK prompt and a new stop date is entered.
- NEW PSJOCFLG S PSJOCFLG=1
- ;
- R1 ;
- I $$EXPIRED^PSGOER(DFN,ON55) D Q
- .W !?3," THIS ORDER HAS BEEN INACTIVE FOR ONE OR MORE SCHEDULED ADMINISTRATIONS"
- .W !?20," AND CANNOT BE RENEWED!"
- ;*287 - Prevent renewal if schedule invalid
- I $G(P(9))]"",'$$DOW^PSIVUTL(P(9)),'$$PRNOK^PSGS0(P(9)) I '$D(^PS(51.1,"AC","PSJ",P(9))) D Q
- . W !!?3,"This order contains an invalid schedule and CANNOT be renewed!" D PAUSE^VALM1
- I '$G(PSGDT) D NOW^%DTC S PSGDT=+$E(%,1,12) ;*258 - Set PSGDT
- N PSJRNWDT,PSJOSTOP,OREASON S PSJRNWDT=$$DATE2^PSJUTL2(PSGDT) S:$G(ON55) PSJOSTOP=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,3) I '(PSJOSTOP>P(2)),$G(PSGDT) S PSJOSTOP=PSGDT
- S (PSIVOK,EDIT)="25^1" S P2=P(2),P(2)=PSJRNWDT D EDIT^PSIVEDT S P(2)=P2 K P2 I X="^" Q
- NEW PSGORQF K PSGORQF S PSIVRNFG=1 D:$G(PSJOCFLG) OC^PSIVOC K PSJOCFLG D:'$G(PSGORQF) IN^PSJOCDS($G(ON55),"IV","") K PSIVRNFG W ! Q:$G(PSGORQF)
- S P(11)=$$ENRNAT^PSGOU($P($G(^PS(55,DFN,"IV",+ON55,2)),U,10),+VAIN(4),P(9),P(11))
- D OK G:X["N" R1 I X=U D RD Q
- S PSIVCHG=2
- S P(17)="A",OREASON=P("RES"),P("RES")="R",P("FRES")="" D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D Q:'$D(P("NAT"))
- .D NATURE^PSIVOREN I '$D(P("NAT")) D RD Q
- .S ON=ON55
- S P(16)="",PSJORIFN="",PSIVACT=1,P("21FLG")="",P("RES")=OREASON D SET55^PSIVORFB
- D:$P(^PS(55,DFN,"IV",+ON55,0),U,17)="A" RUPDATE^PSIVOREN(DFN,ON55,P(2))
- I PSJIVORF,$P(^PS(55,DFN,"IV",+ON55,0),U,17)'="A" S X=$$LS^PSSLOCK(DFN,+ON55_"V") D
- .D EXPOE^PSGOER(DFN,ON55)
- .S P("RES")="R",PSJREN=1
- .D ENUDTX^PSJOREN(DFN,ON55,"NR"),EN1^PSJHL2(DFN,"SN",+ON55_"V","ORDER RENEWED"),UPDREN(DFN,ON55,PSJRNWDT,P(6),PSJOSTOP,P("NAT"))
- S OD=P(2)
- D VF1^PSJLIACT("","",1),UNL^PSSLOCK(DFN,+ON55_"V")
- D ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"R")
- I $G(PSJOSTOP),$G(ON55),$G(DFN) D STIX^PSIVOREN(PSJOSTOP,ON55,DFN)
- Q
- ;
- RD ; Delete for renew.
- ;Q:'$G(PSJVFY)
- ;D DEL55^PSIVORE2 S (ON55,P("OLDON"))=P("PON") D GT55^PSIVORFB
- Q
- ;
- OK ;Print example label, run order through checker, ask if it is ok.
- S P16=0,PSIVEXAM=1,(PSIVNOL,PSIVCT)=1 D GTOT^PSIVUTL(P(4)) I ($G(P("PD"))="") D GTPD^PSIVORE2
- D ^PSIVCHK I $D(DUOUT) S X="^",COMQUIT=1 Q
- I ERR=1 S X="N",COMQUIT=1 Q
- W ! D ^PSIVORLB K PSIVEXAM S Y=P(2) W !,"Start date: " X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),?30," Stop date: " S Y=P(3) X ^DD("DD") W $P(Y,"@")," ",$P(Y,"@",2),!
- ;PSJ*5*157 EFD FOR IV
- D EFDIV^PSJUTL($G(ZZND))
- I $G(PSIVCHG),($G(PSIVREA)'="R") W !,"*** This change will cause a new order to be created. ***"
- S X="Is this O.K.: ^"_$S(ERR:"N",1:"Y")_"^^NO"_$S(ERR'=1:",YES",1:"") D ENQ^PSIV I X["?" S HELP="OK" D ^PSIVHLP G OK
- Q
- ;
- RI ; Reinstate Auto-DC'ed order.
- N DA,DIE,DIR,DIU,DR,PSIVACT,PSIVALT,PSIVALCK,PSIVREA W !!,$C(7),"This order has been Auto-DC'ed."
- S DIR(0)="Y",DIR("A")="Reinstate this order" D ^DIR K DIR I 'Y S ERR=1 Q
- D NOW^%DTC I %>$P($G(^PS(55,DFN,"IV",+ON55,2)),U,7) D
- .K DIR S ERR=1,DIR(0)="Y",DIR("A",1)="The original stop date of this order has past.",DIR("A")="Do you wish to renew this order" D ^DIR K DIR S ERR=$S(Y:2,1:1)
- Q:$G(ERR) S X=$G(^VA(200,+P(6),"PS")) I $S('X:1,'$P(X,U,4):0,DT<$P(X,U,4):0,1:1) S ERR=1
- I $G(ERR) W !!,$C(7),"This order's provider is no longer valid. Please enter a valid provider." S (EDIT,PSIVOK)=1 D EDIT^PSIVEDT I $G(DONE) W $C(7),"Order unchanged." S ERR=1 Q
- N PSGALO S PSGALO=18530 D ENARI^PSIVOPT(DFN,ON,DUZ,PSGALO)
- Q
- ;
- UPDREN(DFN,ORD,RNWDT,PROV,OSTOPDT,PSJNOO) ;
- Q:'DFN!'ORD!'RNWDT!'PROV!'OSTOPDT!(PSJNOO="")
- ;*PSJ*5*258
- N DR,DA,DIC,DIE,DD,DO,ND0,PSGOEORD,DINUM
- S DIC="^PS(55,"_DFN_",""IV"","_+ORD S ND0=$G(@(DIC_",0)")),PSGOEORD=$P(ND0,"^",21) I $G(ON)["P",$G(PSGOLDOE) S PSGOEORD=PSGOLDOE
- S DIC=DIC_",14,",DIC(0)="L",DIC("P")="55.1138DA",ND14=$G(@(DIC_"0)")),DINUM=$P(ND14,"^",3)+1,DA(2)=DFN,DA(1)=+ORD D
- .S DIC("DR")=".01////"_$G(RNWDT)_";1////"_$G(DUZ)_";2////"_$G(PROV)_";3////"_$G(OSTOPDT)_";4////"_+PSGOEORD,X=$G(RNWDT) D FILE^DICN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVOPT2 6528 printed Jan 18, 2025@03:05:46 Page 2
- PSIVOPT2 ;BIR/PR,MLM-OPTION DRIVER (CONT) ;02 Mar 99 / 9:27 AM
- +1 ;;5.0;INPATIENT MEDICATIONS ;**23,29,58,110,127,133,135,157,181,258,287,374**;16 DEC 97;Build 2
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA# 2191.
- +4 ; Reference to ^PSSLOCK is supported by DBIA #2789
- +5 ;
- D ; Discontinue order.
- +1 DO NATURE^PSIVOREN
- IF '$DATA(P("NAT"))
- WRITE !,$CHAR(7),"Order Unchanged."
- SET COMQUIT=1
- QUIT
- +2 ;* 8/2* D EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED"),D1
- +3 IF '$$REQPROV^PSGOEC
- WRITE !,$CHAR(7),"Order Unchanged."
- SET (COMQUIT,PROVQUIT)=1
- QUIT
- +4 IF 'PSJCOM
- Begin DoDot:1
- +5 DO D1
- +6 SET PSIVALT=1
- SET PSIVALCK="STOP"
- SET PSIVREA="D"
- SET ON=ON55
- DO LOG^PSIVORAL
- SET P(3)=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,3)
- End DoDot:1
- +7 IF PSJCOM
- NEW COMFLG
- SET COMFLG=0
- Begin DoDot:1
- +8 IF ON55'["P"
- NEW COMFLG,O,OO
- SET (COMFLG,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
- +9 if OO=ON55
- QUIT
- IF '$$LS^PSSLOCK(DFN,OO)
- SET COMFLG=1
- QUIT
- End DoDot:2
- End DoDot:1
- +10 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
- +11 IF OO["V"
- SET ON55=OO
- DO D1
- SET PSIVALT=1
- SET PSIVALCK="STOP"
- SET PSIVREA="D"
- SET ON=ON55
- DO LOG^PSIVORAL
- NEW PSJORD
- SET P(3)=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,3)
- SET PSJORD=ON55
- DO HL^PSIVORA
- QUIT
- +12 IF OO["U"
- NEW PSGORD,PSJORD,PSJNOO
- KILL DA
- DO NOW^%DTC
- SET PSGDT=%
- SET T=$EXTRACT("T",'PSJSYSU)
- SET PSGALR=20
- SET PSGP=DFN
- SET DA=+OO
- SET DA(1)=PSGP
- SET (PSGORD,PSJORD)=OO
- SET PSJNOO=P("NAT")
- Begin DoDot:2
- +13 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)))
- DO ASET^PSGOEC
- DO AC^PSGOEC
- End DoDot:2
- End DoDot:1
- +14 QUIT
- D1 NEW %,DA,DIE,DIU,STP,NSTOP
- +1 SET NSTOP=$$DATE^PSJUTL2()
- 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 KILL TMP
- +3 SET TMP(55.01,""_+ON55_","_DFN_","_"",109)=NSTOP
- +4 if '$PIECE($GET(^PS(55,DFN,"IV",+ON55,2)),U,7)
- SET TMP(55.01,""_+ON55_","_DFN_","_"",116)=STP
- +5 SET TMP(55.01,""_+ON55_","_DFN_","_"",100)="D"
- +6 SET TMP(55.01,""_+ON55_","_DFN_","_"",157)=""
- +7 SET TMP(55.01,""_+ON55_","_DFN_","_"",.03)=NSTOP
- +8 SET PSIVACT=1
- +9 DO FILE^DIE("","TMP")
- +10 KILL TMP
- +11 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))
- +12 ;* S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'ORIFN
- if '$DATA(PSJIVORF)
- DO ORPARM^PSIVOREN
- if 'PSJIVORF
- QUIT
- +13 QUIT
- +14 ;
- R ; Renew order.
- +1 ;I PSJCOM D RIV^PSJCOMR Q
- +2 IF PSJCOM
- DO ^PSJCOMR
- QUIT
- +3 IF P(17)="D"
- IF P(12)
- NEW ERR
- DO RI
- if $GET(ERR)=1
- WRITE $CHAR(7)," Order unchanged."
- IF $GET(ERR)<2
- SET COMQUIT=1
- QUIT
- +4 IF $GET(PSGORQF)
- SET COMQUIT=1
- QUIT
- +5 ;PSJOCFLG is killed of after the OC is performed. The Dosing is still need to trigger(again) if the
- +6 ; user said "no" at OK prompt and a new stop date is entered.
- +7 NEW PSJOCFLG
- SET PSJOCFLG=1
- +8 ;
- R1 ;
- +1 IF $$EXPIRED^PSGOER(DFN,ON55)
- Begin DoDot:1
- +2 WRITE !?3," THIS ORDER HAS BEEN INACTIVE FOR ONE OR MORE SCHEDULED ADMINISTRATIONS"
- +3 WRITE !?20," AND CANNOT BE RENEWED!"
- End DoDot:1
- QUIT
- +4 ;*287 - Prevent renewal if schedule invalid
- +5 IF $GET(P(9))]""
- IF '$$DOW^PSIVUTL(P(9))
- IF '$$PRNOK^PSGS0(P(9))
- IF '$DATA(^PS(51.1,"AC","PSJ",P(9)))
- Begin DoDot:1
- +6 WRITE !!?3,"This order contains an invalid schedule and CANNOT be renewed!"
- DO PAUSE^VALM1
- End DoDot:1
- QUIT
- +7 ;*258 - Set PSGDT
- IF '$GET(PSGDT)
- DO NOW^%DTC
- SET PSGDT=+$EXTRACT(%,1,12)
- +8 NEW PSJRNWDT,PSJOSTOP,OREASON
- SET PSJRNWDT=$$DATE2^PSJUTL2(PSGDT)
- if $GET(ON55)
- SET PSJOSTOP=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,3)
- IF '(PSJOSTOP>P(2))
- IF $GET(PSGDT)
- SET PSJOSTOP=PSGDT
- +9 SET (PSIVOK,EDIT)="25^1"
- SET P2=P(2)
- SET P(2)=PSJRNWDT
- DO EDIT^PSIVEDT
- SET P(2)=P2
- KILL P2
- IF X="^"
- QUIT
- +10 NEW PSGORQF
- KILL PSGORQF
- SET PSIVRNFG=1
- if $GET(PSJOCFLG)
- DO OC^PSIVOC
- KILL PSJOCFLG
- if '$GET(PSGORQF)
- DO IN^PSJOCDS($GET(ON55),"IV","")
- KILL PSIVRNFG
- WRITE !
- if $GET(PSGORQF)
- QUIT
- +11 SET P(11)=$$ENRNAT^PSGOU($PIECE($GET(^PS(55,DFN,"IV",+ON55,2)),U,10),+VAIN(4),P(9),P(11))
- +12 DO OK
- if X["N"
- GOTO R1
- IF X=U
- DO RD
- QUIT
- +13 SET PSIVCHG=2
- +14 SET P(17)="A"
- SET OREASON=P("RES")
- SET P("RES")="R"
- SET P("FRES")=""
- if '$DATA(PSJIVORF)
- DO ORPARM^PSIVOREN
- IF PSJIVORF
- Begin DoDot:1
- +15 DO NATURE^PSIVOREN
- IF '$DATA(P("NAT"))
- DO RD
- QUIT
- +16 SET ON=ON55
- End DoDot:1
- if '$DATA(P("NAT"))
- QUIT
- +17 SET P(16)=""
- SET PSJORIFN=""
- SET PSIVACT=1
- SET P("21FLG")=""
- SET P("RES")=OREASON
- DO SET55^PSIVORFB
- +18 if $PIECE(^PS(55,DFN,"IV",+ON55,0),U,17)="A"
- DO RUPDATE^PSIVOREN(DFN,ON55,P(2))
- +19 IF PSJIVORF
- IF $PIECE(^PS(55,DFN,"IV",+ON55,0),U,17)'="A"
- SET X=$$LS^PSSLOCK(DFN,+ON55_"V")
- Begin DoDot:1
- +20 DO EXPOE^PSGOER(DFN,ON55)
- +21 SET P("RES")="R"
- SET PSJREN=1
- +22 DO ENUDTX^PSJOREN(DFN,ON55,"NR")
- DO EN1^PSJHL2(DFN,"SN",+ON55_"V","ORDER RENEWED")
- DO UPDREN(DFN,ON55,PSJRNWDT,P(6),PSJOSTOP,P("NAT"))
- End DoDot:1
- +23 SET OD=P(2)
- +24 DO VF1^PSJLIACT("","",1)
- DO UNL^PSSLOCK(DFN,+ON55_"V")
- +25 DO ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"R")
- +26 IF $GET(PSJOSTOP)
- IF $GET(ON55)
- IF $GET(DFN)
- DO STIX^PSIVOREN(PSJOSTOP,ON55,DFN)
- +27 QUIT
- +28 ;
- RD ; Delete for renew.
- +1 ;Q:'$G(PSJVFY)
- +2 ;D DEL55^PSIVORE2 S (ON55,P("OLDON"))=P("PON") D GT55^PSIVORFB
- +3 QUIT
- +4 ;
- OK ;Print example label, run order through checker, ask if it is ok.
- +1 SET P16=0
- SET PSIVEXAM=1
- SET (PSIVNOL,PSIVCT)=1
- DO GTOT^PSIVUTL(P(4))
- IF ($GET(P("PD"))="")
- DO GTPD^PSIVORE2
- +2 DO ^PSIVCHK
- IF $DATA(DUOUT)
- SET X="^"
- SET COMQUIT=1
- QUIT
- +3 IF ERR=1
- SET X="N"
- SET COMQUIT=1
- QUIT
- +4 WRITE !
- DO ^PSIVORLB
- KILL PSIVEXAM
- SET Y=P(2)
- WRITE !,"Start date: "
- XECUTE ^DD("DD")
- WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2),?30," Stop date: "
- SET Y=P(3)
- XECUTE ^DD("DD")
- WRITE $PIECE(Y,"@")," ",$PIECE(Y,"@",2),!
- +5 ;PSJ*5*157 EFD FOR IV
- +6 DO EFDIV^PSJUTL($GET(ZZND))
- +7 IF $GET(PSIVCHG)
- IF ($GET(PSIVREA)'="R")
- WRITE !,"*** This change will cause a new order to be created. ***"
- +8 SET X="Is this O.K.: ^"_$SELECT(ERR:"N",1:"Y")_"^^NO"_$SELECT(ERR'=1:",YES",1:"")
- DO ENQ^PSIV
- IF X["?"
- SET HELP="OK"
- DO ^PSIVHLP
- GOTO OK
- +9 QUIT
- +10 ;
- RI ; Reinstate Auto-DC'ed order.
- +1 NEW DA,DIE,DIR,DIU,DR,PSIVACT,PSIVALT,PSIVALCK,PSIVREA
- WRITE !!,$CHAR(7),"This order has been Auto-DC'ed."
- +2 SET DIR(0)="Y"
- SET DIR("A")="Reinstate this order"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET ERR=1
- QUIT
- +3 DO NOW^%DTC
- IF %>$PIECE($GET(^PS(55,DFN,"IV",+ON55,2)),U,7)
- Begin DoDot:1
- +4 KILL DIR
- SET ERR=1
- SET DIR(0)="Y"
- SET DIR("A",1)="The original stop date of this order has past."
- SET DIR("A")="Do you wish to renew this order"
- DO ^DIR
- KILL DIR
- SET ERR=$SELECT(Y:2,1:1)
- End DoDot:1
- +5 if $GET(ERR)
- QUIT
- SET X=$GET(^VA(200,+P(6),"PS"))
- IF $SELECT('X:1,'$PIECE(X,U,4):0,DT<$PIECE(X,U,4):0,1:1)
- SET ERR=1
- +6 IF $GET(ERR)
- WRITE !!,$CHAR(7),"This order's provider is no longer valid. Please enter a valid provider."
- SET (EDIT,PSIVOK)=1
- DO EDIT^PSIVEDT
- IF $GET(DONE)
- WRITE $CHAR(7),"Order unchanged."
- SET ERR=1
- QUIT
- +7 NEW PSGALO
- SET PSGALO=18530
- DO ENARI^PSIVOPT(DFN,ON,DUZ,PSGALO)
- +8 QUIT
- +9 ;
- UPDREN(DFN,ORD,RNWDT,PROV,OSTOPDT,PSJNOO) ;
- +1 if 'DFN!'ORD!'RNWDT!'PROV!'OSTOPDT!(PSJNOO="")
- QUIT
- +2 ;*PSJ*5*258
- +3 NEW DR,DA,DIC,DIE,DD,DO,ND0,PSGOEORD,DINUM
- +4 SET DIC="^PS(55,"_DFN_",""IV"","_+ORD
- SET ND0=$GET(@(DIC_",0)"))
- SET PSGOEORD=$PIECE(ND0,"^",21)
- IF $GET(ON)["P"
- IF $GET(PSGOLDOE)
- SET PSGOEORD=PSGOLDOE
- +5 SET DIC=DIC_",14,"
- SET DIC(0)="L"
- SET DIC("P")="55.1138DA"
- SET ND14=$GET(@(DIC_"0)"))
- SET DINUM=$PIECE(ND14,"^",3)+1
- SET DA(2)=DFN
- SET DA(1)=+ORD
- Begin DoDot:1
- +6 SET DIC("DR")=".01////"_$GET(RNWDT)_";1////"_$GET(DUZ)_";2////"_$GET(PROV)_";3////"_$GET(OSTOPDT)_";4////"_+PSGOEORD
- SET X=$GET(RNWDT)
- DO FILE^DICN
- End DoDot:1
- +7 QUIT