PSIVOPT1.m

PSIVOPT1 ;BIR/MLM-EDIT/DC ORDER (BACKDOOR) ;22 OCT 97 / 3:14 PM

 ;;5.0; INPATIENT MEDICATIONS ;**29,58,101,110,127**;16 DEC 97

 ;

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

 ; Reference to ^PSSLOCK is supported by DBIA #2789

 ;

E ; Edit order through Pharmacy.

 NEW PSJEDFLG

 D GSTRING^PSIVORE1,GTFLDS^PSIVORFE

 I '$G(PSIVENO) S PSIVENO=1 D EN^VALM("PSJ LM IV AC/EDIT") S VALMBCK="Q"

 Q

ACCEPT ; To be called by ACCEPT^PSJLIACT

 I $G(PSJEDFLG) S VALMBCK="" Q

 I '$G(PSJEDIT1) D CKNEW I PSIVCHG D

 .S P("OLDON")=ON55,Y=$G(^PS(55,DFN,"IV",+ON55,0)) D NOW^%DTC S P("LOG")=$E(%,1,12)

 . S P("CLRK")=DUZ_U_$P($G(^VA(200,DUZ,0)),U)

 .I $G(PSGSDX)!$G(PSGFDX) Q

 .I $P(Y,U,2)=P(2),$P(Y,U,3)=P(3) D ENT^PSIVCAL S X=P(2),%DT="T" D ^%DT S P(2)=$E(Y,1,12),PSJEDIT1=1 D ENSTOP^PSIVCAL

 K PSJEDFLG

 D OK^PSIVOPT2

 I X["N" S VALMBCK="R" Q

 I X["^" D GT55^PSIVORFB W !,"Order unchanged." Q

 ;;I $G(P(21))]"" D CKNEW,@$S(PSIVCHG:"NEWORD",1:"UPDATE") Q:$D(X)

 I $G(P("21FLG"))]"" D CKNEW,@$S(PSIVCHG:"NEWORD",1:"UPDATE") Q:$D(X)

 ;;S PSJORL=$$ENORL^PSJUTL($G(VAIN(4))) S ON=ON55,OD=P(2) D EN^PSIVORE,^PSIVORE1

 S PSJORL=$$ENORL^PSJUTL($G(VAIN(4))) S ON=ON55,OD=P(2)

 ;D:ON["V" EN^PSIVORE,^PSIVORE1

 D:ON["V" EN^PSIVORE

 ;;I $G(PSJIVORF),PSIVCHG D EN1^PSJHL2(DFN,"SN",+ON55_"V","NEW ORDER") NEW PSIVXX S PSIVXX=$$LS^PSSLOCK(DFN,+ON55_"V")

 I $G(PSJIVORF),PSIVCHG D EN1^PSJHL2(DFN,"SN",ON55,"NEW ORDER") NEW PSIVXX S PSIVXX=$$LS^PSSLOCK(DFN,ON55)

 S PSIVACEP=1

 Q

 ;

CKNEW ; Check if new order is to be created.

 N DNE,ND,TDRG S (DRG("DRGC"),DNE,PSIVCHG)=0

 Q:PSIVCHG  F DRGT="AD","SOL" F DRGI=0:0 S DRGI=$O(DRG(DRGT,DRGI)) Q:'DRGI  S TDRG(DRGT,+$P(DRG(DRGT,DRGI),U),DRGI)=$P(DRG(DRGT,DRGI),U,3) I $P(P("OT"),U)="F",'$P(DRG(DRGT,DRGI),U,5) S P("OT")="I"

 F DRGT="AD","SOL" Q:DRGT="SOL"&(P("DTYP")=1)  F DRGI=0:0 S DRGI=$O(^PS(55,DFN,"IV",+ON55,DRGT,DRGI)) Q:'DRGI!DNE  D

 .S X=$G(^PS(55,DFN,"IV",+ON55,DRGT,DRGI,0)),DRG("DRGC")=$G(DRG("DRGC"))+1

 .I $D(TDRG(DRGT,+$P(X,U),DRGI)),$P(X,U,2)=$P(TDRG(DRGT,+$P(X,U),DRGI),U) Q

 .S (PSIVCHG,DNE)=1

 Q:PSIVCHG

 I $G(DRG("AD",0))+$S(P("DTYP")=1:0,1:+$G(DRG("SOL",0)))'=DRG("DRGC") S PSIVCHG=1 Q

 S ND(0)=$G(^PS(55,DFN,"IV",+ON55,0)),ND("PD")=$G(^PS(55,DFN,"IV",+ON55,.2))

 N X S X=$S($P(ND(0),U,8)["@":$P($P(ND(0),U,8),"@"),1:$P(ND(0),U,8))

 S ND=$S($E(P("OT"))="I":$P(ND("PD"),U,1,2)_U,1:"")_$P(ND("PD"),U,3)_U_$S($E(P("OT"))'="I":X_U,1:"")_+$P(ND(0),U,6)_U_$P(ND(0),U,2)_U_$P(ND(0),U,3)_U_$P(ND(0),U,9)

 S:ND'=($S($E(P("OT"))="I":+P("PD")_U_$G(P("DO"))_U,1:"")_+P("MR")_U_$S($E(P("OT"))'="I":$S(P(8)["@":$P(P(8),"@"),1:P(8))_U,1:"")_+P(6)_U_P(2)_U_P(3)_U_P(9)) PSIVCHG=1

 ;* S ND=$S($E(P("OT"))="I":$P(ND("PD"),U,1,2)_U,1:"")_$P(ND("PD"),U,3)_U_$S($E(P("OT"))'="I":$P(ND(0),U,8)_U,1:"")_+$P(ND(0),U,6)_U_$P(ND(0),U,2)_U_$P(ND(0),U,3)_U_$P(ND(0),U,9)

 ;* S:ND'=($S($E(P("OT"))="I":+P("PD")_U_$G(P("DO"))_U,1:"")_+P("MR")_U_$S($E(P("OT"))'="I":P(8)_U,1:"")_+P(6)_U_P(2)_U_P(3)_U_P(9)) PSIVCHG=1

 Q

 ;

UPDATE ; Update original order.

 S PSIVALT=1,PSIVALCK="EN",PSIVREA="E",ON=ON55 K P("OLDON") D LOG^PSIVORAL

 D SET55^PSIVORFB,ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"E")

 D:'$D(PSJIVORF) ORPARM^PSIVOREN K X Q:'PSJIVORF

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

 S P("NAT")=""

 D EN1^PSJHL2(DFN,"XX",+ON55_"V","UPDATED ORDER")

 K X

 Q

 ;

NEWORD ; DC orig. order, get new order no.

 D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D NATURE^PSIVOREN I '$D(P("NAT")) S X=1 W !,"Order unchanged." Q

 ;;S P("RES")="E",P("OLDON")=ON55,P(16)="" K ON55 D NEW55^PSIVORFB S (P("PON"),P("NEWON"),ON)=ON55,ON55=P("OLDON")

 S P("RES")="E",P("OLDON")=ON55,P(16)=""

 Q:$$NONVF()

 I '($G(PSIVCOPY)=2) K ON55 D NEW55^PSIVORFB

 S (P("PON"),P("NEWON"),ON)=ON55,ON55=P("OLDON") S:($G(PSIVCOPY)=2) P("OLDON")=""

 I $P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)="A" D D1^PSIVOPT2 D

 . I PSJIVORF,$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) D EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED")

 . ;;S P(21)="" W !!,"Original order discontinued...",!!

 . S P("21FLG")="" W !!,"Original order discontinued...",!!

 . D UNL^PSSLOCK(DFN,+ON55_"V")

 F ON55=P("NEWON"),P("OLDON") K DA,DIE,DR D

 .S DA(1)=DFN,DA=+ON55,DIE="^PS(55,"_DFN_",""IV"",",DR=$S((ON55=P("NEWON")&(+ON55'=+P("OLDON"))):"113////"_P("OLDON")_";122////E",1:"114////"_P("NEWON")_";123////E") D ^DIE

 .I ON55=P("NEWON") N CLINAPPT S CLINAPPT=$G(^PS(55,DFN,"IV",+P("OLDON"),"DSS")) D

 ..S:CLINAPPT DR=DR_";136////"_+CLINAPPT S:$P(CLINAPPT,"^",2) DR=DR_";139////"_$P(CLINAPPT,"^",2)

 .D ^DIE

 .Q:ON55=P("OLDON")&($P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)'="D")

 .D:ON55=P("NEWON") SET55^PSIVORFB

 .D:ON55=P("NEWON") VF1^PSJLIACT("","",0)

 .D ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,$S(ON55=P("NEWON"):"N",1:"DE"))

 .S PSIVREA="E",PSIVAL="Order "_$S(ON55=P("OLDON"):"discontinued",1:"created")_" due to edit" S:ON55=P("OLDON") PSIVALCK="STOP" D LOG^PSIVORAL

 L -^PS(55,DFN,"IV",+P("OLDON")) ;D NEWENT^PSIVORFE

 K X S ON55=P("NEWON"),P(17)="A" Q:'PSJIVORF  D SET^PSIVORFE

 Q

 ;

NEWSTOP ; Set stop date for DC and renewals.

 S ND=$G(^PS(55,DFN,"IV",+ON55,0)),Y=+$P(ND,U,3),$P(^PS(55,DFN,"IV",+P("OLDON"),2),U,7)=Y,NSTOP=$S(NSTOP>Y:Y,1:NSTOP),$P(^PS(55,DFN,"IV",+ON55,0),U,3)=NSTOP

 K DA,DIK S DIK="^PS(55,"_DFN_",""IV"",",DA(1)=DFN,DA=+P("OLDON") D IX^DIK K DA,DIK

 Q

NONVF()   ;

 NEW PSGOEAV S PSGOEAV=+$P(PSJSYSP0,U,9)

 I +PSJSYSU=3,PSGOEAV Q 0

 I +PSJSYSU=1,PSGOEAV Q 0

 K DA D ENGNN^PSGOETO S (ON,P("NEWON"))=DA_"P",P(17)="N"

 S (P("DO"),P("PD"))=""

 D GTPD^PSIVORE2,PUT531^PSIVORFA

 I $P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)="A" D D1^PSIVOPT2 D

 . I PSJIVORF,$P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,21) D EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED")

 . S P("21FLG")="" W !!,"Original order discontinued...",!!

 . D UNL^PSSLOCK(DFN,+P("OLDON")_"V")

 F ON55=P("NEWON"),P("OLDON") K DA,DIE,DR D

 . S DA=+ON55

 . S:ON55=P("NEWON") DIE="^PS(53.1,",DR="104////"_P("OLDON")_";103////E"

 . S:ON55=P("OLDON") DA(1)=DFN,DIE="^PS(55,"_DFN_",""IV"",",DR="114////"_P("NEWON")_";123////E"

 . D ^DIE

 . Q:ON55=P("OLDON")&($P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)'="D")

 . I ON55=P("OLDON") D

 .. D ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,$S(ON55=P("NEWON"):"N",1:"DE"))

 .. S PSIVALT="",PSIVREA="E",PSIVAL="Order discontinued due to edit" S PSIVALCK="STOP" D LOG^PSIVORAL

 . D:ON55=P("NEWON") NEWNVAL^PSGAL5(ON55,4100,"","")

 L -^PS(55,DFN,"IV",+P("OLDON"))

 K X S (ON,ON55)=P("NEWON")

 D EN1^PSJHL2(DFN,"SN",ON,"ORDER CREATED")

 S X=$$LS^PSSLOCK(DFN,ON)

 D GT531^PSIVORFA(DFN,ON)

 I ON["P" N CLINAPPT S CLINAPPT=$G(^PS(55,DFN,"IV",+ON,"DSS")) I CLINAPPT D  K DIE,DA,DR

 . S:CLINAPPT DR="136////"_+CLINAPPT_";" S:$P(CLINAPPT,"^",2) DR=DR_"139////"_$P(CLINAPPT,"^",2)_";" D ^DIE

 S VALMBCK="Q"

 S PSGACT="EL"

 I P(17)="N",(P("OLDON")=""),(P("CLRK")=DUZ) S PSGACT="ELD"

 I +PSJSYSU=3!(+PSJSYSU=1) S PSGACT="DELV"

 Q 1

PSIVOPT1  ;BIR/MLM-EDIT/DC ORDER (BACKDOOR) ;22 OCT 97 / 3:14 PM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**29,58,101,110,127**;16 DEC 97

 +2       ;

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

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

 +5       ;

E         ; Edit order through Pharmacy.

 +1        NEW PSJEDFLG

 +2        DO GSTRING^PSIVORE1

           DO GTFLDS^PSIVORFE

 +3        IF '$GET(PSIVENO)

               SET PSIVENO=1

               DO EN^VALM("PSJ LM IV AC/EDIT")

               SET VALMBCK="Q"

 +4        QUIT 

ACCEPT    ; To be called by ACCEPT^PSJLIACT

 +1        IF $GET(PSJEDFLG)

               SET VALMBCK=""

               QUIT 

 +2        IF '$GET(PSJEDIT1)

               DO CKNEW

               IF PSIVCHG

                   Begin DoDot:1

 +3                    SET P("OLDON")=ON55

                       SET Y=$GET(^PS(55,DFN,"IV",+ON55,0))

                       DO NOW^%DTC

                       SET P("LOG")=$EXTRACT(%,1,12)

 +4                    SET P("CLRK")=DUZ_U_$PIECE($GET(^VA(200,DUZ,0)),U)

 +5                    IF $GET(PSGSDX)!$GET(PSGFDX)

                           QUIT 

 +6                    IF $PIECE(Y,U,2)=P(2)

                           IF $PIECE(Y,U,3)=P(3)

                               DO ENT^PSIVCAL

                               SET X=P(2)

                               SET %DT="T"

                               DO ^%DT

                               SET P(2)=$EXTRACT(Y,1,12)

                               SET PSJEDIT1=1

                               DO ENSTOP^PSIVCAL

                   End DoDot:1

 +7        KILL PSJEDFLG

 +8        DO OK^PSIVOPT2

 +9        IF X["N"

               SET VALMBCK="R"

               QUIT 

 +10       IF X["^"

               DO GT55^PSIVORFB

               WRITE !,"Order unchanged."

               QUIT 

 +11      ;;I $G(P(21))]"" D CKNEW,@$S(PSIVCHG:"NEWORD",1:"UPDATE") Q:$D(X)

 +12       IF $GET(P("21FLG"))]""

               DO CKNEW

               DO @$SELECT(PSIVCHG:"NEWORD",1:"UPDATE")

               IF $DATA(X)

                   QUIT 

 +13      ;;S PSJORL=$$ENORL^PSJUTL($G(VAIN(4))) S ON=ON55,OD=P(2) D EN^PSIVORE,^PSIVORE1

 +14       SET PSJORL=$$ENORL^PSJUTL($GET(VAIN(4)))

           SET ON=ON55

           SET OD=P(2)

 +15      ;D:ON["V" EN^PSIVORE,^PSIVORE1

 +16       IF ON["V"

               DO EN^PSIVORE

 +17      ;;I $G(PSJIVORF),PSIVCHG D EN1^PSJHL2(DFN,"SN",+ON55_"V","NEW ORDER") NEW PSIVXX S PSIVXX=$$LS^PSSLOCK(DFN,+ON55_"V")

 +18       IF $GET(PSJIVORF)

               IF PSIVCHG

                   DO EN1^PSJHL2(DFN,"SN",ON55,"NEW ORDER")

                   NEW PSIVXX

                   SET PSIVXX=$$LS^PSSLOCK(DFN,ON55)

 +19       SET PSIVACEP=1

 +20       QUIT 

 +21      ;

CKNEW     ; Check if new order is to be created.

 +1        NEW DNE,ND,TDRG

           SET (DRG("DRGC"),DNE,PSIVCHG)=0

 +2        IF PSIVCHG

               QUIT 

           FOR DRGT="AD","SOL"

               FOR DRGI=0:0

                   SET DRGI=$ORDER(DRG(DRGT,DRGI))

                   IF 'DRGI

                       QUIT 

                   SET TDRG(DRGT,+$PIECE(DRG(DRGT,DRGI),U),DRGI)=$PIECE(DRG(DRGT,DRGI),U,3)

                   IF $PIECE(P("OT"),U)="F"

                       IF '$PIECE(DRG(DRGT,DRGI),U,5)

                           SET P("OT")="I"

 +3        FOR DRGT="AD","SOL"

               IF DRGT="SOL"&(P("DTYP")=1)

                   QUIT 

               FOR DRGI=0:0

                   SET DRGI=$ORDER(^PS(55,DFN,"IV",+ON55,DRGT,DRGI))

                   IF 'DRGI!DNE

                       QUIT 

                   Begin DoDot:1

 +4                    SET X=$GET(^PS(55,DFN,"IV",+ON55,DRGT,DRGI,0))

                       SET DRG("DRGC")=$GET(DRG("DRGC"))+1

 +5                    IF $DATA(TDRG(DRGT,+$PIECE(X,U),DRGI))

                           IF $PIECE(X,U,2)=$PIECE(TDRG(DRGT,+$PIECE(X,U),DRGI),U)

                               QUIT 

 +6                    SET (PSIVCHG,DNE)=1

                   End DoDot:1

 +7        IF PSIVCHG

               QUIT 

 +8        IF $GET(DRG("AD",0))+$SELECT(P("DTYP")=1:0,1:+$GET(DRG("SOL",0)))'=DRG("DRGC")

               SET PSIVCHG=1

               QUIT 

 +9        SET ND(0)=$GET(^PS(55,DFN,"IV",+ON55,0))

           SET ND("PD")=$GET(^PS(55,DFN,"IV",+ON55,.2))

 +10       NEW X

           SET X=$SELECT($PIECE(ND(0),U,8)["@":$PIECE($PIECE(ND(0),U,8),"@"),1:$PIECE(ND(0),U,8))

 +11       SET ND=$SELECT($EXTRACT(P("OT"))="I":$PIECE(ND("PD"),U,1,2)_U,1:"")_$PIECE(ND("PD"),U,3)_U_$SELECT($EXTRACT(P("OT"))'="I":X_U,1:"")_+$PIECE(ND(0),U,6)_U_$PIECE(ND(0),U,2)_U_$PIECE(ND(0),U,3)_U_$PIECE(ND(0),U,9)

 +12       IF ND'=($SELECT($EXTRACT(P("OT"))="I"

               SET PSIVCHG=1

 +13      ;* S ND=$S($E(P("OT"))="I":$P(ND("PD"),U,1,2)_U,1:"")_$P(ND("PD"),U,3)_U_$S($E(P("OT"))'="I":$P(ND(0),U,8)_U,1:"")_+$P(ND(0),U,6)_U_$P(ND(0),U,2)_U_$P(ND(0),U,3)_U_$P(ND(0),U,9)

 +14      ;* S:ND'=($S($E(P("OT"))="I":+P("PD")_U_$G(P("DO"))_U,1:"")_+P("MR")_U_$S($E(P("OT"))'="I":P(8)_U,1:"")_+P(6)_U_P(2)_U_P(3)_U_P(9)) PSIVCHG=1

 +15       QUIT 

 +16      ;

UPDATE    ; Update original order.

 +1        SET PSIVALT=1

           SET PSIVALCK="EN"

           SET PSIVREA="E"

           SET ON=ON55

           KILL P("OLDON")

           DO LOG^PSIVORAL

 +2        DO SET55^PSIVORFB

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

 +3        IF '$DATA(PSJIVORF)

               DO ORPARM^PSIVOREN

           KILL X

           IF 'PSJIVORF

               QUIT 

 +4        SET PSJORIFN=$PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,21)

           IF 'PSJORIFN

               QUIT 

 +5        SET P("NAT")=""

 +6        DO EN1^PSJHL2(DFN,"XX",+ON55_"V","UPDATED ORDER")

 +7        KILL X

 +8        QUIT 

 +9       ;

NEWORD    ; DC orig. order, get new order no.

 +1        IF '$DATA(PSJIVORF)

               DO ORPARM^PSIVOREN

           IF PSJIVORF

               DO NATURE^PSIVOREN

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

                   SET X=1

                   WRITE !,"Order unchanged."

                   QUIT 

 +2       ;;S P("RES")="E",P("OLDON")=ON55,P(16)="" K ON55 D NEW55^PSIVORFB S (P("PON"),P("NEWON"),ON)=ON55,ON55=P("OLDON")

 +3        SET P("RES")="E"

           SET P("OLDON")=ON55

           SET P(16)=""

 +4        IF $$NONVF()

               QUIT 

 +5        IF '($GET(PSIVCOPY)=2)

               KILL ON55

               DO NEW55^PSIVORFB

 +6        SET (P("PON"),P("NEWON"),ON)=ON55

           SET ON55=P("OLDON")

           IF ($GET(PSIVCOPY)=2)

               SET P("OLDON")=""

 +7        IF $PIECE($GET(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)="A"

               DO D1^PSIVOPT2

               Begin DoDot:1

 +8                IF PSJIVORF

                       IF $PIECE($GET(^PS(55,DFN,"IV",+ON55,0)),U,21)

                           DO EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED")

 +9       ;;S P(21)="" W !!,"Original order discontinued...",!!

 +10               SET P("21FLG")=""

                   WRITE !!,"Original order discontinued...",!!

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

               End DoDot:1

 +12       FOR ON55=P("NEWON"),P("OLDON")

               KILL DA,DIE,DR

               Begin DoDot:1

 +13               SET DA(1)=DFN

                   SET DA=+ON55

                   SET DIE="^PS(55,"_DFN_",""IV"","

                   SET DR=$SELECT((ON55=P("NEWON")&(+ON55'=+P("OLDON"))):"113////"_P("OLDON")_";122////E",1:"114////"_P("NEWON")_";123////E")

                   DO ^DIE

 +14               IF ON55=P("NEWON")

                       NEW CLINAPPT

                       SET CLINAPPT=$GET(^PS(55,DFN,"IV",+P("OLDON"),"DSS"))

                       Begin DoDot:2

 +15                       IF CLINAPPT

                               SET DR=DR_";136////"_+CLINAPPT

                           IF $PIECE(CLINAPPT,"^",2)

                               SET DR=DR_";139////"_$PIECE(CLINAPPT,"^",2)

                       End DoDot:2

 +16               DO ^DIE

 +17               IF ON55=P("OLDON")&($PIECE($GET(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)'="D")

                       QUIT 

 +18               IF ON55=P("NEWON")

                       DO SET55^PSIVORFB

 +19               IF ON55=P("NEWON")

                       DO VF1^PSJLIACT("","",0)

 +20               DO ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,$SELECT(ON55=P("NEWON"):"N",1:"DE"))

 +21               SET PSIVREA="E"

                   SET PSIVAL="Order "_$SELECT(ON55=P("OLDON"):"discontinued",1:"created")_" due to edit"

                   IF ON55=P("OLDON")

                       SET PSIVALCK="STOP"

                   DO LOG^PSIVORAL

               End DoDot:1

 +22      ;D NEWENT^PSIVORFE

           LOCK -^PS(55,DFN,"IV",+P("OLDON"))

 +23       KILL X

           SET ON55=P("NEWON")

           SET P(17)="A"

           IF 'PSJIVORF

               QUIT 

           DO SET^PSIVORFE

 +24       QUIT 

 +25      ;

NEWSTOP   ; Set stop date for DC and renewals.

 +1        SET ND=$GET(^PS(55,DFN,"IV",+ON55,0))

           SET Y=+$PIECE(ND,U,3)

           SET $PIECE(^PS(55,DFN,"IV",+P("OLDON"),2),U,7)=Y

           SET NSTOP=$SELECT(NSTOP>Y:Y,1:NSTOP)

           SET $PIECE(^PS(55,DFN,"IV",+ON55,0),U,3)=NSTOP

 +2        KILL DA,DIK

           SET DIK="^PS(55,"_DFN_",""IV"","

           SET DA(1)=DFN

           SET DA=+P("OLDON")

           DO IX^DIK

           KILL DA,DIK

 +3        QUIT 

NONVF()   ;

 +1        NEW PSGOEAV

           SET PSGOEAV=+$PIECE(PSJSYSP0,U,9)

 +2        IF +PSJSYSU=3

               IF PSGOEAV

                   QUIT 0

 +3        IF +PSJSYSU=1

               IF PSGOEAV

                   QUIT 0

 +4        KILL DA

           DO ENGNN^PSGOETO

           SET (ON,P("NEWON"))=DA_"P"

           SET P(17)="N"

 +5        SET (P("DO"),P("PD"))=""

 +6        DO GTPD^PSIVORE2

           DO PUT531^PSIVORFA

 +7        IF $PIECE($GET(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)="A"

               DO D1^PSIVOPT2

               Begin DoDot:1

 +8                IF PSJIVORF

                       IF $PIECE($GET(^PS(55,DFN,"IV",+P("OLDON"),0)),U,21)

                           DO EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED")

 +9                SET P("21FLG")=""

                   WRITE !!,"Original order discontinued...",!!

 +10               DO UNL^PSSLOCK(DFN,+P("OLDON")_"V")

               End DoDot:1

 +11       FOR ON55=P("NEWON"),P("OLDON")

               KILL DA,DIE,DR

               Begin DoDot:1

 +12               SET DA=+ON55

 +13               IF ON55=P("NEWON")

                       SET DIE="^PS(53.1,"

                       SET DR="104////"_P("OLDON")_";103////E"

 +14               IF ON55=P("OLDON")

                       SET DA(1)=DFN

                       SET DIE="^PS(55,"_DFN_",""IV"","

                       SET DR="114////"_P("NEWON")_";123////E"

 +15               DO ^DIE

 +16               IF ON55=P("OLDON")&($PIECE($GET(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)'="D")

                       QUIT 

 +17               IF ON55=P("OLDON")

                       Begin DoDot:2

 +18                       DO ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,$SELECT(ON55=P("NEWON"):"N",1:"DE"))

 +19                       SET PSIVALT=""

                           SET PSIVREA="E"

                           SET PSIVAL="Order discontinued due to edit"

                           SET PSIVALCK="STOP"

                           DO LOG^PSIVORAL

                       End DoDot:2

 +20               IF ON55=P("NEWON")

                       DO NEWNVAL^PSGAL5(ON55,4100,"","")

               End DoDot:1

 +21       LOCK -^PS(55,DFN,"IV",+P("OLDON"))

 +22       KILL X

           SET (ON,ON55)=P("NEWON")

 +23       DO EN1^PSJHL2(DFN,"SN",ON,"ORDER CREATED")

 +24       SET X=$$LS^PSSLOCK(DFN,ON)

 +25       DO GT531^PSIVORFA(DFN,ON)

 +26       IF ON["P"

               NEW CLINAPPT

               SET CLINAPPT=$GET(^PS(55,DFN,"IV",+ON,"DSS"))

               IF CLINAPPT

                   Begin DoDot:1

 +27                   IF CLINAPPT

                           SET DR="136////"_+CLINAPPT_";"

                       IF $PIECE(CLINAPPT,"^",2)

                           SET DR=DR_"139////"_$PIECE(CLINAPPT,"^",2)_";"

                       DO ^DIE

                   End DoDot:1

                   KILL DIE,DA,DR

 +28       SET VALMBCK="Q"

 +29       SET PSGACT="EL"

 +30       IF P(17)="N"

               IF (P("OLDON")="")

                   IF (P("CLRK")=DUZ)

                       SET PSGACT="ELD"

 +31       IF +PSJSYSU=3!(+PSJSYSU=1)

               SET PSGACT="DELV"

 +32       QUIT 1