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

PSIVOPT.m

Go to the documentation of this file. 
  1. PSIVOPT ;BIR/PR,MLM-OPTION DRIVER ;06 Aug 98 / 2:17 PM
  1.  ;;5.0; INPATIENT MEDICATIONS ;**17,27,58,88,104,110,155**;16 DEC 97
  1.  ;
  1.  ; Reference to ^PS(55 is supported by DBIA# 2191
  1.  ; Reference to ^PSDRUG is supported by DBIA# 2192        
  1.  ; Reference to ^PS(52.6 is supported by DBIA# 1231
  1.  ; Reference to ^PS(52.7 is supported by DBIA# 2173
  1.  ;
  1.  NEW PSIVLOCK S PSIVLOCK=0
  1.  ;I ON["P" L +^PS(53.1,+ON):1 S:'$T PSIVLOCK=1
  1.  I ON["V" L +^PS(55,DFN,"IV",+ON55):1 S:'$T PSIVLOCK=1
  1.  I PSIVLOCK W !,$C(7),$C(7),"This order is being edited by another user. Try later." G K
  1.  ;W ! L +^PS(55,DFN,"IV",+ON55):1 I '$T W !,$C(7),$C(7),"This order is being edited by another user. Try later." G K
  1.  I PSIVAC="O"!(PSIVAC="H") S PSIVAC=PSIVAC_"(DFN,ON,P(17),P(3))"
  1.  S TEX="Active order ***" I $D(UWLFLAG),UWLFLAG="1.001" S XED=0 D @PSIVAC G K
  1.  S DONE=0 F  D ACT Q:DONE
  1.  ;
  1. UNLOCK ; Unlock order.
  1.  ;I ON["P" L -^PS(53.1,+ON)
  1.  ;E  L -^PS(55,DFN,"IV",+ON55)
  1.  I ON["V" L -^PS(55,DFN,"IV",+ON55)
  1.  ;
  1. K ; Kill variables.
  1.  K %,DA,DIE,DIK,DLAYGO,DNE,DR,DRG,DRGI,DRGT,ERR,HELP,J,OD,P,P16,PSIVAL,PSIVC,PSIVLOG,PSIVNOL,PSIVOK,PSIVOPT,PSIVREA,SCRNPRO,TEX,XED
  1.  Q
  1. ACT ; Prompt for order action.
  1.  K PSJIVBD NEW PSGFDX,PSGSDX S (PSJORD,ON)=ON55
  1.  S PSJCOM=$S(ON["V":$P($G(^PS(55,DFN,"IV",+ON,.2)),"^",8),1:$P($G(^PS(53.1,+ON,.2)),"^",8))
  1.  D:ON["V" EN^PSJLIORD(DFN,ON)
  1.  I ON["P",($P($G(^PS(53.1,+ON,0)),U,9)="N"),'PSJCOM D GT531^PSIVORFA(DFN,ON),VF^PSIVORC2 S DONE=1 Q
  1.  I ON["P",PSJCOM Q:'$$LOCK^PSJOEA(DFN,PSJCOM)  N PSJO,ON,PSJORD S PSJO=0 F  S PSJO=$O(^PS(53.1,"ACX",PSJCOM,PSJO)) Q:'PSJO  Q:$G(Y)="Q"  S (PSJORD,ON)=PSJO_"P" D
  1.  .D:($P($G(^PS(53.1,+ON,0)),U,9)="N") GT531^PSIVORFA(DFN,ON),VF^PSIVORC2
  1.  .D:($P($G(^PS(53.1,+ON,0)),U,9)="P") EN^PSJLIFN
  1.  I $G(PSJCOM) N PSJORD S PSJORD=PSJCOM D CHK^PSJOEA1
  1.  I ON'["V",'+$G(PSJCOM) D EN^PSJLIFN
  1.  S DONE=1
  1.  Q
  1.  ;
  1. CK ; Check if drugs are still valid.
  1.  F DRGT="AD","SOL" S FIL=$S(DRGT="AD":52.6,1:52.7) F DRGI=0:0 S DRGI=$O(DRG(DRGT,DRGI)) Q:'DRGI  D
  1.  .S DRG=+$P(DRG(DRGT,DRGI),U),X=$G(^PS(FIL,DRG,"I")) I $S('X:0,DT<X:0,1:1)!$S('$G(^PSDRUG(+$P($G(^PS(FIL,DRG,0)),U,2),"I")):0,^("I")>DT:0,1:1) S ERR=1
  1.  Q
  1.  ;
  1. D ; Discontinue order.
  1.  D D^PSIVOPT2
  1.  Q
  1.  ;
  1. O(DFN,ON,STAT,STOP) ; On/Off Call
  1.  D NOW^%DTC I STAT="H",STOP<% D EXPIR Q
  1.  I "OA"'[STAT W !,$C(7),"Only active orders may be placed on hold." Q
  1.  S PSIVALT=1,PSIVREA=$S(STAT'="O":"O",1:"C"),(P(17),STAT)=$S(PSIVREA="O":"O",1:"A") W:PSIVREA="C" ?$X+4,$C(7),TEX
  1.  D UPSTAT,LOG^PSIVORAL D:STAT="A" CKO^PSIVCHK
  1.  Q
  1.  ;
  1. E ; Entry for Pharmacy edit
  1.  N PSJEDIT1 D E^PSIVOPT1
  1.  Q
  1.  ;
  1. R ; Renew order.
  1.  D R^PSIVOPT2
  1.  Q
  1.  ;
  1. H(DFN,ON,STAT,STOP)          ; Place order on hold.
  1.  D NOW^%DTC I STAT="H" I STOP<% D EXPIR Q
  1.  I "HA"'[STAT W !,$C(7),"Only active orders may be placed on hold." Q
  1.  D NATURE^PSIVOREN I '$D(P("NAT")) W !!,"Order unchanged." Q
  1.  S PSIVALT=1,PSIVREA=$S(STAT'="H":"H",1:"U"),(P(17),STAT)=$S(PSIVREA="H":"H",1:"A") W:PSIVREA="U" ?$X+4,$C(7),TEX
  1.  D UPSTAT,LOG^PSIVORAL,HOLD^PSIVOE,ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,$S(PSIVREA="H":"H1",1:"H0")) D:STAT="A" CKO^PSIVCHK
  1.  Q
  1.  ;
  1. S ; View order.
  1.  D @$S(ON55["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA("_DFN_","""_ON55_""")") W @IOF D EN^PSIVORV2
  1.  Q
  1.  ;
  1. EXPIR ; Update status of expired orders.
  1.  I STAT="H" S PSIVREA="H",P(17)="E"
  1.  S STAT="E" D UPSTAT,EXPIR^PSIVOE W $C(7),"  This order has expired."
  1.  Q
  1.  ;
  1. UPSTAT ; Update orders status.
  1.  N DA,DR,DIE,PSIVACT S PSIVACT=1,DA=+ON55,DA(1)=DFN,DIE="^PS(55,"_DFN_",""IV"",",DR="100///"_P(17)_$S($G(PSIVREA)="H":";149///1",$G(PSIVREA)="U":";149///@",1:"") D ^DIE
  1.  Q
  1.  ;
  1. ENIN ; Entry for inpatient order entry/profile options.
  1.  N DFN,ON,P,PSIVAC S PSIVAC="C" I PSJORD["P" S (P("PON"),ON)=+PSJORD_"P",DFN=PSGP D SHOW1^PSIVORC Q
  1.  S (P("PON"),ON,ON55)=+PSJORD_"V",DFN=PSGP D GT55^PSIVORFB,EN^PSIVORV2,PSIVOPT:'$D(PSJPRF)
  1.  L -^PS(55,DFN,"IV",+PSJORD)
  1.  Q
  1.  ;
  1. ENARI(DFN,ON,PSGUOW,PSIVAL) ; Auto-reinstate IV orders if movement is deleted.
  1.  ;Create a list of recipients beyond normal mail group
  1.  S PSGORNUM=$S($G(PSGORD):PSGORD,$G(PSJORD):PSJORD,$G(OR55):OR55,1:"")
  1.  I $G(PSGORNUM) D
  1.  .I $D(^PS(55,PSGP,"IV",+PSGORNUM,0)),$P(^PS(55,PSGP,"IV",+PSGORNUM,0),U,6)'="" S PSJSENTO($J,$P(^PS(55,PSGP,"IV",+PSGORNUM,0),U,6))="" ; Provider
  1.  .I $D(^PS(55,PSGP,"IV",+PSGORNUM,2)),$P(^PS(55,PSGP,"IV",+PSGORNUM,2),U,11)'="" S PSJSENTO($J,$P(^PS(55,PSGP,"IV",+PSGORNUM,2),U,11))="" ; Entered by
  1.  .I $D(^PS(55,PSGP,"IV",+PSGORNUM,4)),$P(^PS(55,PSGP,"IV",+PSGORNUM,4),U,1)'="" S PSJSENTO($J,$P(^PS(55,PSGP,"IV",+PSGORNUM,4),U,1))="" ; Verifying Nurse
  1.  ; find pharmacist that finished the IV order
  1.  N PSJX,ENTBY S PSJX=$G(^PS(55,PSGP,"IV",+ON,"A",1,0))
  1.  I $P(PSJX,U,2)="F" S ENTBY=$$VA200($P(PSJX,U,3)) I ENTBY'="" S PSJSENTO($J,ENTBY)=""
  1.  ;
  1.  I $G(PSGALO)'=18530,$G(PSGORNUM),$$IVDUPADD^PSIVOPT(PSGP,+PSGORNUM) S ^TMP("PSJNOTUNDC",$J,PSGP,+PSGORNUM_"V")="" Q
  1.  N DA,DR,DIE,DIK,PSIVREA,PSIVALCK,PSIVOPT,PSIVALT,X,Y
  1.  S X=$G(^PS(55,DFN,"IV",+ON,"ADC")) I X K ^PS(55,"ADC",X,DFN,+ON),^PS(55,DFN,"IV",+ON,"ADC")
  1.  S PSIVACT=1,DR=$S(+$P($G(^PS(55,DFN,"IV",+ON,4)),U,18)=1:"100///H",+$P($G(^PS(55,DFN,"IV",+ON,0)),U,10)=1:"100///H",1:"100///A")_";.03////"_+$P($G(^PS(55,DFN,"IV",+ON,2)),U,7)_";109///@;116///@;121///@"
  1.  S DIE="^PS(55,"_DFN_",""IV"",",DA=+ON,DA(1)=DFN
  1.  N CHKIT S CHKIT=$G(^PS(55,DFN,"IV",+ON,2)) I $P(CHKIT,U,6)["P",($P(CHKIT,U,9)="R") S DR=DR_";114///@;123///@"
  1.  D ^DIE
  1.  S ^TMP("PSJUNDC",$J,DFN,ON_"V")=""
  1.  S ON55=ON,P(17)="A",PSIVREA=$S($D(PSJUNDC):"AI",1:"I"),PSIVALCK="STOP",(PSIVOPT,PSIVALT)=1,PSIVAL=$P($G(^PS(53.3,+PSIVAL,0)),U) D LOG^PSIVORAL
  1.  ;* S Y=^PS(55,DFN,"IV",+ON,0),P(3)=+$P(Y,U,3),ORIFN=$P(Y,U,21),P(12)="" D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D
  1.  S Y=^PS(55,DFN,"IV",+ON,0),P(3)=+$P(Y,U,3),P(12)="" D:'$D(PSJIVORF) ORPARM^PSIVOREN I PSJIVORF D
  1.  .D EN1^PSJHL2(DFN,"SC",+ON55_"V","AUTO REINSTATED")
  1.  S PSGTOL=$S($D(PSJUNDC):3,1:2)
  1.  Q:$S('$D(PSJUNDC):0,PSGALO=18540:1,1:'$P($G(PSJSYSW0),U,15))
  1.  I $D(^PS(53.41,1,1,PSGUOW,1,DFN,1,3,1,+ON)) K DIK,DA S DIK="^PS(53.41,1,1,"_PSGUOW_",1,"_DFN_",1,3,1,",DA=+ON,DA(1)=1,DA(2)=PSGP,DA(3)=PSGUOW,DA(4)=3 D ^DIK
  1.  E  K DA D ENLBL^PSIVOPT(PSGTOL,PSGUOW,DFN,3,+ON,"RE")
  1.  Q
  1.  ;
  1. ENINP(DFN,ON) ; Entry from Inpatient Profile.
  1.  N PSIVAC,ON55 S PSIVAC="PRO" D @($S(ON["V":"GT55^PSIVORFB",1:"GT531^PSIVORFA("_DFN_","""_ON_""")")),ENNH^PSIVORV2(ON)
  1.  Q
  1. ENLBL(PSGTOL,PSGUOW,PSGP,PSGTOO,DA,RES) ;
  1.  ;Queue MAR labels for IV orders.
  1.  Q:'$D(^DPT(PSGP,.1))  I '$D(PSJSYSW0) N PSJACPF,PSJACNWP S PSJACPF=11 D WP^PSJAC Q:'PSJSYSL
  1.  N P,X,Y
  1.  S X=$P(PSJSYSW0,U,2),Y=$P($G(^PS(55,PSGP,"IV",DA,0)),U,4)
  1.  S Y=$S(Y="A":4,Y="H":5,Y="C":6,1:3) I X=1!(X[Y) D NOW^%DTC S PSGDT=% D ENL^PSGVDS S ^PS(55,DFN,"IV",DA,7)=PSGDT_U_RES
  1.  Q
  1.  ;
  1. IVDUPADD(PSGP,ORDERNUM) ;
  1.  N PSJCOM
  1.  S DUPLOOP=0
  1.  S DUPFOUND=0
  1.  ;Loop through the additives of order to reinstate
  1.  S PSJCOM=+$P($G(^PS(55,+PSGP,"IV",ORDERNUM,.2)),"^",8) F  S DUPLOOP=$O(^PS(55,PSGP,"IV",ORDERNUM,"AD",DUPLOOP)) Q:((DUPLOOP="")!(DUPFOUND))  D
  1.  .;Get the additive code no.
  1.  .S TARGET=$P(^PS(55,PSGP,"IV",ORDERNUM,"AD",DUPLOOP,0),"^",1)
  1.  .D NOW^%DTC
  1.  .S DATELOOP=%
  1.  .;Loop through the current orders for the patient by date
  1.  .F  S DATELOOP=$O(^PS(55,PSGP,"IV","AIS",DATELOOP)) Q:((DATELOOP="")!(DUPFOUND))  D
  1.  ..S EXISTORD=""
  1.  ..;Loop through the orders for date by order number
  1.  ..F  S EXISTORD=$O(^PS(55,PSGP,"IV","AIS",DATELOOP,EXISTORD)) Q:((EXISTORD="")!(DUPFOUND))  D
  1.  ...;Loop through additives for the existing order
  1.  ...I PSJCOM>0 Q:+$P($G(^PS(55,+PSGP,"IV",EXISTORD,.2)),"^",8)
  1.  ...S EXISTADD=0
  1.  ...F  S EXISTADD=$O(^PS(55,PSGP,"IV",EXISTORD,"AD",EXISTADD)) Q:((EXISTADD="")!(DUPFOUND))  D 
  1.  ....;Extract the Additive Code number for the Order
  1.  ....S MATCHADD=$P(^PS(55,PSGP,"IV",EXISTORD,"AD",EXISTADD,0),"^",1)
  1.  ....;If the existing order and the order to be reinstated have the same additive code then return FOUND=TRUE
  1.  ....I MATCHADD=TARGET D
  1.  .....S DUPFOUND=1
  1.  Q DUPFOUND
  1.  ;
  1. VA200(X) ;Return the IEN for the user.
  1.  ; X = User name
  1.  NEW DIC,Y S DIC="^VA(200,",DIC(0)="NZ" D ^DIC
  1.  I +Y=-1 Q ""
  1.  Q $P(Y,U)