Routine: PSIVOPT2

PSIVOPT2 ;BIR/PR,MLM-OPTION DRIVER (CONT) ;29-May-2012 14:34;PLS

 ;;5.0; INPATIENT MEDICATIONS ;**23,29,58,1009,1013,110,127,133,135,157,1015**;16 DEC 97;Build 62

 ; Reference to ^PS(55 is supported by DBIA# 2191.

 ; Reference to ^PSSLOCK is supported by DBIA #2789

 ;Modified - IHS/MSC/PLS - 12/09/10 - Line R+3

 ;                         10/16/11 - Line D+1

D ; Discontinue order.

 N INCOM

 S INCOM=$$INPTCOM^APSPFUNC()

 I '$L(INCOM) W !,$C(7),"Order Unchanged." Q

 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=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

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_","_"",.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

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

 NEW PSGORQF S PSIVRNFG=1 D ORDCHK^PSJLIFN K PSIVRNFG W !

 I $T(OI^APSPMULT)]"" N OI S OI=+$G(^PS(55,DFN,"IV",+PSJORD,.2)) I '$$OI^APSPMULT(OI) W $C(7),"Sorry, this drug is not currently available in this facility" Q    ;IHS/MSC/JDS - 12/09/10 - MDF

 I $G(PSGORQF) S COMQUIT=1 Q

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!"

 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

 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)

RD ; Delete for renew.

 ;Q:'$G(PSJVFY)

 ;D DEL55^PSIVORE2 S (ON55,P("OLDON"))=P("PON") D GT55^PSIVORFB

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

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)

UPDREN(DFN,ORD,RNWDT,PROV,OSTOPDT,PSJNOO) ;

 Q:'DFN!'ORD!'RNWDT!'PROV!'OSTOPDT!(PSJNOO="")

 K DR,DA,DIC,DIE,DD,DO N ND0,PSGOEORD

 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

 K DO,DINUM

PSIVOPT2  ;BIR/PR,MLM-OPTION DRIVER (CONT) ;29-May-2012 14:34;PLS

 +1       ;;5.0; INPATIENT MEDICATIONS ;**23,29,58,1009,1013,110,127,133,135,157,1015**;16 DEC 97;Build 62

 +2       ;

 +3       ; Reference to ^PS(55 is supported by DBIA# 2191.

 +4       ; Reference to ^PSSLOCK is supported by DBIA #2789

 +5       ;

 +6       ;Modified - IHS/MSC/PLS - 12/09/10 - Line R+3

 +7       ;                         10/16/11 - Line D+1

D         ; Discontinue order.

 +1        NEW INCOM

 +2        SET INCOM=$$INPTCOM^APSPFUNC()

 +3        IF '$LENGTH(INCOM)

               WRITE !,$CHAR(7),"Order Unchanged."

               QUIT

 +4        DO NATURE^PSIVOREN

           IF '$DATA(P("NAT"))

               WRITE !,$CHAR(7),"Order Unchanged."

               SET COMQUIT=1

               QUIT

 +5       ;* 8/2* D EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED"),D1

 +6        IF '$$REQPROV^PSGOEC

               WRITE !,$CHAR(7),"Order Unchanged."

               SET COMQUIT=1

               QUIT

 +7        IF 'PSJCOM

               Begin DoDot:1

 +8                DO D1

 +9                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

 +10       IF PSJCOM

               NEW COMFLG

               SET COMFLG=0

               Begin DoDot:1

 +11               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

 +12                               IF OO=ON55

                                       QUIT

                                   IF '$$LS^PSSLOCK(DFN,OO)

                                       SET COMFLG=1

                                       QUIT

                               End DoDot:2

               End DoDot:1

 +13       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

 +14                       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

 +15                       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

 +16                               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

 +17       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_","_"",.03)=NSTOP

 +7        SET PSIVACT=1

 +8        DO FILE^DIE("","TMP")

 +9        KILL TMP

 +10       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))

 +11      ;* S ORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'ORIFN

           IF '$DATA(PSJIVORF)

               DO ORPARM^PSIVOREN

           IF 'PSJIVORF

               QUIT

 +12       QUIT

 +13      ;

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        NEW PSGORQF

           SET PSIVRNFG=1

           DO ORDCHK^PSJLIFN

           KILL PSIVRNFG

           WRITE !

 +5       ;IHS/MSC/JDS - 12/09/10 - MDF

           IF $TEXT(OI^APSPMULT)]""

               NEW OI

               SET OI=+$GET(^PS(55,DFN,"IV",+PSJORD,.2))

               IF '$$OI^APSPMULT(OI)

                   WRITE $CHAR(7),"Sorry, this drug is not currently available in this facility"

                   QUIT

 +6        IF $GET(PSGORQF)

               SET COMQUIT=1

               QUIT

 +7       ;

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        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

 +5        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

 +6        SET P(11)=$$ENRNAT^PSGOU($PIECE($GET(^PS(55,DFN,"IV",+ON55,2)),U,10),+VAIN(4),P(9),P(11))

 +7        DO OK

           IF X["N"

               GOTO R1

           IF X=U

               DO RD

               QUIT

 +8        SET PSIVCHG=2

 +9        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

 +10               DO NATURE^PSIVOREN

                   IF '$DATA(P("NAT"))

                       DO RD

                       QUIT

 +11               SET ON=ON55

               End DoDot:1

               IF '$DATA(P("NAT"))

                   QUIT

 +12       SET P(16)=""

           SET PSJORIFN=""

           SET PSIVACT=1

           SET P("21FLG")=""

           SET P("RES")=OREASON

           DO SET55^PSIVORFB

 +13       IF $PIECE(^PS(55,DFN,"IV",+ON55,0),U,17)="A"

               DO RUPDATE^PSIVOREN(DFN,ON55,P(2))

 +14       IF PSJIVORF

               IF $PIECE(^PS(55,DFN,"IV",+ON55,0),U,17)'="A"

                   SET X=$$LS^PSSLOCK(DFN,+ON55_"V")

                   Begin DoDot:1

 +15                   DO EXPOE^PSGOER(DFN,ON55)

 +16                   SET P("RES")="R"

                       SET PSJREN=1

 +17                   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

 +18       SET OD=P(2)

 +19       DO VF1^PSJLIACT("","",1)

           DO UNL^PSSLOCK(DFN,+ON55_"V")

 +20       DO ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"R")

 +21       IF $GET(PSJOSTOP)

               IF $GET(ON55)

                   IF $GET(DFN)

                       DO STIX^PSIVOREN(PSJOSTOP,ON55,DFN)

 +22       QUIT

 +23      ;

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        KILL DR,DA,DIC,DIE,DD,DO

           NEW ND0,PSGOEORD

 +3        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

 +4        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

 +5            SET DIC("DR")=".01////"_$GET(RNWDT)_";1////"_$GET(DUZ)_";2////"_$GET(PROV)_";3////"_$GET(OSTOPDT)_";4////"_+PSGOEORD

               SET X=$GET(RNWDT)

               DO FILE^DICN

 +6            QUIT

           End DoDot:1

 +7        KILL DO,DINUM

PSIVOPT2.m