Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSIVOPT1

PSIVOPT1.m

Go to the documentation of this file.
  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
  1. ;
  1. ; Reference to ^PS(55 is supported by DBIA 2191
  1. ; Reference to ^PSSLOCK is supported by DBIA #2789
  1. ;
  1. E ; Edit order through Pharmacy.
  1. NEW PSJEDFLG
  1. D GSTRING^PSIVORE1,GTFLDS^PSIVORFE
  1. I '$G(PSIVENO) S PSIVENO=1 D EN^VALM("PSJ LM IV AC/EDIT") S VALMBCK="Q"
  1. Q
  1. ACCEPT ; To be called by ACCEPT^PSJLIACT
  1. I $G(PSJEDFLG) S VALMBCK="" Q
  1. I '$G(PSJEDIT1) D CKNEW I PSIVCHG D
  1. .S P("OLDON")=ON55,Y=$G(^PS(55,DFN,"IV",+ON55,0)) D NOW^%DTC S P("LOG")=$E(%,1,12)
  1. . S P("CLRK")=DUZ_U_$P($G(^VA(200,DUZ,0)),U)
  1. .I $G(PSGSDX)!$G(PSGFDX) Q
  1. .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
  1. K PSJEDFLG
  1. D OK^PSIVOPT2
  1. I X["N" S VALMBCK="R" Q
  1. I X["^" D GT55^PSIVORFB W !,"Order unchanged." Q
  1. ;;I $G(P(21))]"" D CKNEW,@$S(PSIVCHG:"NEWORD",1:"UPDATE") Q:$D(X)
  1. I $G(P("21FLG"))]"" D CKNEW,@$S(PSIVCHG:"NEWORD",1:"UPDATE") Q:$D(X)
  1. ;;S PSJORL=$$ENORL^PSJUTL($G(VAIN(4))) S ON=ON55,OD=P(2) D EN^PSIVORE,^PSIVORE1
  1. S PSJORL=$$ENORL^PSJUTL($G(VAIN(4))) S ON=ON55,OD=P(2)
  1. ;D:ON["V" EN^PSIVORE,^PSIVORE1
  1. D:ON["V" EN^PSIVORE
  1. ;;I $G(PSJIVORF),PSIVCHG D EN1^PSJHL2(DFN,"SN",+ON55_"V","NEW ORDER") NEW PSIVXX S PSIVXX=$$LS^PSSLOCK(DFN,+ON55_"V")
  1. I $G(PSJIVORF),PSIVCHG D EN1^PSJHL2(DFN,"SN",ON55,"NEW ORDER") NEW PSIVXX S PSIVXX=$$LS^PSSLOCK(DFN,ON55)
  1. S PSIVACEP=1
  1. Q
  1. ;
  1. CKNEW ; Check if new order is to be created.
  1. N DNE,ND,TDRG S (DRG("DRGC"),DNE,PSIVCHG)=0
  1. 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"
  1. 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
  1. .S X=$G(^PS(55,DFN,"IV",+ON55,DRGT,DRGI,0)),DRG("DRGC")=$G(DRG("DRGC"))+1
  1. .I $D(TDRG(DRGT,+$P(X,U),DRGI)),$P(X,U,2)=$P(TDRG(DRGT,+$P(X,U),DRGI),U) Q
  1. .S (PSIVCHG,DNE)=1
  1. Q:PSIVCHG
  1. I $G(DRG("AD",0))+$S(P("DTYP")=1:0,1:+$G(DRG("SOL",0)))'=DRG("DRGC") S PSIVCHG=1 Q
  1. S ND(0)=$G(^PS(55,DFN,"IV",+ON55,0)),ND("PD")=$G(^PS(55,DFN,"IV",+ON55,.2))
  1. N X S X=$S($P(ND(0),U,8)["@":$P($P(ND(0),U,8),"@"),1:$P(ND(0),U,8))
  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":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)
  1. 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
  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)
  1. ;* 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
  1. Q
  1. ;
  1. UPDATE ; Update original order.
  1. S PSIVALT=1,PSIVALCK="EN",PSIVREA="E",ON=ON55 K P("OLDON") D LOG^PSIVORAL
  1. D SET55^PSIVORFB,ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"E")
  1. D:'$D(PSJIVORF) ORPARM^PSIVOREN K X Q:'PSJIVORF
  1. S PSJORIFN=$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) Q:'PSJORIFN
  1. S P("NAT")=""
  1. D EN1^PSJHL2(DFN,"XX",+ON55_"V","UPDATED ORDER")
  1. K X
  1. Q
  1. ;
  1. NEWORD ; DC orig. order, get new order no.
  1. D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D NATURE^PSIVOREN I '$D(P("NAT")) S X=1 W !,"Order unchanged." Q
  1. ;;S P("RES")="E",P("OLDON")=ON55,P(16)="" K ON55 D NEW55^PSIVORFB S (P("PON"),P("NEWON"),ON)=ON55,ON55=P("OLDON")
  1. S P("RES")="E",P("OLDON")=ON55,P(16)=""
  1. Q:$$NONVF()
  1. I '($G(PSIVCOPY)=2) K ON55 D NEW55^PSIVORFB
  1. S (P("PON"),P("NEWON"),ON)=ON55,ON55=P("OLDON") S:($G(PSIVCOPY)=2) P("OLDON")=""
  1. I $P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)="A" D D1^PSIVOPT2 D
  1. . I PSJIVORF,$P($G(^PS(55,DFN,"IV",+ON55,0)),U,21) D EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED")
  1. . ;;S P(21)="" W !!,"Original order discontinued...",!!
  1. . S P("21FLG")="" W !!,"Original order discontinued...",!!
  1. . D UNL^PSSLOCK(DFN,+ON55_"V")
  1. F ON55=P("NEWON"),P("OLDON") K DA,DIE,DR D
  1. .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
  1. .I ON55=P("NEWON") N CLINAPPT S CLINAPPT=$G(^PS(55,DFN,"IV",+P("OLDON"),"DSS")) D
  1. ..S:CLINAPPT DR=DR_";136////"_+CLINAPPT S:$P(CLINAPPT,"^",2) DR=DR_";139////"_$P(CLINAPPT,"^",2)
  1. .D ^DIE
  1. .Q:ON55=P("OLDON")&($P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)'="D")
  1. .D:ON55=P("NEWON") SET55^PSIVORFB
  1. .D:ON55=P("NEWON") VF1^PSJLIACT("","",0)
  1. .D ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,$S(ON55=P("NEWON"):"N",1:"DE"))
  1. .S PSIVREA="E",PSIVAL="Order "_$S(ON55=P("OLDON"):"discontinued",1:"created")_" due to edit" S:ON55=P("OLDON") PSIVALCK="STOP" D LOG^PSIVORAL
  1. L -^PS(55,DFN,"IV",+P("OLDON")) ;D NEWENT^PSIVORFE
  1. K X S ON55=P("NEWON"),P(17)="A" Q:'PSJIVORF D SET^PSIVORFE
  1. Q
  1. ;
  1. NEWSTOP ; Set stop date for DC and renewals.
  1. 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
  1. K DA,DIK S DIK="^PS(55,"_DFN_",""IV"",",DA(1)=DFN,DA=+P("OLDON") D IX^DIK K DA,DIK
  1. Q
  1. NONVF() ;
  1. NEW PSGOEAV S PSGOEAV=+$P(PSJSYSP0,U,9)
  1. I +PSJSYSU=3,PSGOEAV Q 0
  1. I +PSJSYSU=1,PSGOEAV Q 0
  1. K DA D ENGNN^PSGOETO S (ON,P("NEWON"))=DA_"P",P(17)="N"
  1. S (P("DO"),P("PD"))=""
  1. D GTPD^PSIVORE2,PUT531^PSIVORFA
  1. I $P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)="A" D D1^PSIVOPT2 D
  1. . I PSJIVORF,$P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,21) D EN1^PSJHL2(DFN,"OD",+ON55_"V","ORDER DISCONTINUED")
  1. . S P("21FLG")="" W !!,"Original order discontinued...",!!
  1. . D UNL^PSSLOCK(DFN,+P("OLDON")_"V")
  1. F ON55=P("NEWON"),P("OLDON") K DA,DIE,DR D
  1. . S DA=+ON55
  1. . S:ON55=P("NEWON") DIE="^PS(53.1,",DR="104////"_P("OLDON")_";103////E"
  1. . S:ON55=P("OLDON") DA(1)=DFN,DIE="^PS(55,"_DFN_",""IV"",",DR="114////"_P("NEWON")_";123////E"
  1. . D ^DIE
  1. . Q:ON55=P("OLDON")&($P($G(^PS(55,DFN,"IV",+P("OLDON"),0)),U,17)'="D")
  1. . I ON55=P("OLDON") D
  1. .. D ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,$S(ON55=P("NEWON"):"N",1:"DE"))
  1. .. S PSIVALT="",PSIVREA="E",PSIVAL="Order discontinued due to edit" S PSIVALCK="STOP" D LOG^PSIVORAL
  1. . D:ON55=P("NEWON") NEWNVAL^PSGAL5(ON55,4100,"","")
  1. L -^PS(55,DFN,"IV",+P("OLDON"))
  1. K X S (ON,ON55)=P("NEWON")
  1. D EN1^PSJHL2(DFN,"SN",ON,"ORDER CREATED")
  1. S X=$$LS^PSSLOCK(DFN,ON)
  1. D GT531^PSIVORFA(DFN,ON)
  1. I ON["P" N CLINAPPT S CLINAPPT=$G(^PS(55,DFN,"IV",+ON,"DSS")) I CLINAPPT D K DIE,DA,DR
  1. . S:CLINAPPT DR="136////"_+CLINAPPT_";" S:$P(CLINAPPT,"^",2) DR=DR_"139////"_$P(CLINAPPT,"^",2)_";" D ^DIE
  1. S VALMBCK="Q"
  1. S PSGACT="EL"
  1. I P(17)="N",(P("OLDON")=""),(P("CLRK")=DUZ) S PSGACT="ELD"
  1. I +PSJSYSU=3!(+PSJSYSU=1) S PSGACT="DELV"
  1. Q 1