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 Dec 13, 2024@02:04:31 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
