- 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