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

PSIVUTL.m

Go to the documentation of this file.
  1. PSIVUTL ;BIR/MLM - IV UTILITIES ;Jul 05, 2018@08:59
  1. ;;5.0;INPATIENT MEDICATIONS ;**69,58,81,85,110,133,181,263,275,279,373**;16 DEC 97;Build 3
  1. ;
  1. ; Reference to ^DD("DD" is supported by DBIA 10017.
  1. ; Reference to ^PS(50.7 is supported by DBIA 2180.
  1. ; Reference to ^PS(52.6 is supported by DBIA 1231.
  1. ; Reference to ^PS(55 is supported by DBIA 2191.
  1. ; Reference to ^PS(52.7 is supported by DBIA 2173.
  1. ; Reference to ^DIC is supported by DBIA 10006.
  1. ; Reference to ^PS(51.1 is supported by DBIA 2177.
  1. ;
  1. DRGSC(Y,PSJSCT) ; Called to set DIC("S") when selecting Orderable Items.
  1. N OK,ND,NDU,NDI S OK=0
  1. S ND=$G(^PS(50.7,+Y,0))
  1. ;I $P(ND,U,3) S OK=$S('$P(ND,U,4):1,$P(ND,U,4)>DT:1,1:0)
  1. S OK=$S('$P(ND,U,4):1,$P(ND,U,4)>DT:1,1:0)
  1. Q OK
  1. ;
  1. IVDRGSC(Y) ; Set DIC("S") for IV additive/solution selection.
  1. ; Naked reference below refers to full reference in Y, which is either ^PS(52.6, or ^PS(52.7
  1. N Y S Y="S X(1)=$G(^(0)),X(2)=$G(^(""I"")) I $S('X(2):1,X(2)>DT:1,1:0),$D(^PSDRUG(+$P(X(1),U,2),0)) S X(2)=$G(^(""I"")) I $S('+$P(X(1),U,11):0,'X(2):1,X(2)>DT:1,1:0)"
  1. Q Y
  1. ;
  1. ENU(Y) ;Get IV additive strength.
  1. N X S X=$P(^PS(52.6,+Y,0),U,3),Y=$$CODES^PSIVUTL(X,52.6,2)
  1. Q Y
  1. ;
  1. CODES(PSJCD,PSJF,PSJFLD) ; Get name from code.
  1. ; PSJF = one of following files: ^PS(55, ^PS(53.1, ^PS(52.6
  1. D FIELD^DID(PSJF,PSJFLD,"","POINTER","PSJDD")
  1. S Y=$G(PSJDD("POINTER")) K PSJDD
  1. S Y=$P($P(";"_Y,";"_PSJCD_":",2),";")
  1. Q Y
  1. ;
  1. CODES1(PSJCD,PSJF,PSJFLD) ;Check to see if code is valid.
  1. ; PSJF = one of following files: ^PS(55, ^PS(53.1, ^PS(52.6
  1. D FIELD^DID(PSJF,PSJFLD,"","POINTER","PSJDD")
  1. I PSJDD("POINTER")'[PSJCD_":" K PSJDD Q 0
  1. K PSJDD Q 1
  1. ;
  1. CODES2(PSJF,PSJFLD) ;Get field name
  1. ; PSJF = one of following files: ^PS(55, ^PS(53.1, ^PS(52.6
  1. D FIELD^DID(PSJF,PSJFLD,"","LABEL","PSJDD")
  1. Q PSJDD("LABEL")
  1. ;
  1. GTPCI(Y) ; Set up "work" area for provider comments.
  1. N DIC,DINUM,DLAYGO,X S DIC="^PS(53.45,",DIC(0)="LNZ",DLAYGO=53.45,(DINUM,X)=+DUZ D ^DIC
  1. Q Y
  1. ;
  1. WDTE(Y) ; Format and print date.
  1. I 'Y S Y="******"
  1. E X ^DD("DD") S Y=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)
  1. Q Y
  1. GTOT(Y) ; Get order type & protocol
  1. I ($G(ON55)["V"),$G(DFN) D GTNUMLBL(DFN,ON55)
  1. N DRGI,DRGT
  1. S P("OT")=$S(Y="A":"F",Y="H":"H",1:"I")
  1. I P("OT")="F" F DRGT="AD","SOL" F DRGI=0:0 S DRGI=$O(DRG(DRGT,DRGI)) Q:'DRGI I '$P(DRG(DRGT,DRGI),U,5) S P("OT")="I" Q
  1. Q
  1. ;
  1. PIV(ON) ; Display IV orders.
  1. N DRG,ON55,P,PSJORIFN,TYP,X,Y S TYP="?" I ON["V" D
  1. .S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23,25 S P(X)=$P(Y,U,X)
  1. .S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C"
  1. .S ON55=ON,P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") D GTDRG^PSIVORFB,GTOT^PSIVUTL(P(4))
  1. .W $S($P($G(^PS(55,DFN,"IV",+ON,.2)),U,4)="D":" d",1:" ")
  1. .S X=$G(^PS(55,DFN,"IV",+ON,4)) I +PSJSYSU,'+$P(X,U,$S(+PSJSYSU=3:4,1:++PSJSYSU)) W "->"
  1. .S ND14=$G(^PS(55,DFN,"IV",+ON,14,0)),ND14=$P(ND14,U,3) S:ND14 ND14=+$G(^(ND14,0)) ;#373 - Retrieve Renewal Dt, if any
  1. I ON=+ON N O S O="" F S O=$O(^PS(53.1,"ACX",ON,O)) Q:O="" D
  1. . S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+O,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U) D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4)) D PIV(O_"P") W !
  1. I ON["P" D GETP(ON) D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4)) I $E(P("OT"))="I" D Q
  1. . I $G(PSJCLOR) N ND2 S ND2=$G(^PS(53.1,+ON,2)) S P(2)=$P(ND2,"^",2),P(3)=$P(ND2,"^",4)
  1. . NEW MARX,PSIVX
  1. . ;D DRGDISP^PSJLMUT1(PSGP,+ON_"P",40,54,.MARX,0) ;#373
  1. . D DRGDISP^PSJLMUT1(PSGP,+ON_"P",34,28,.MARX,0) ;#373
  1. . F PSIVX=0:0 S PSIVX=$O(MARX(PSIVX)) Q:'PSIVX W @($S(PSIVX=1:"?9",1:"!?11")),MARX(PSIVX) D:PSIVX=1 PIV1
  1. NEW PIV2PRT,RNDTPRT S (PIV2PRT,RNDTPRT)=0 ;#373 - Keep track if PIV2 API run, Renewal Date printed
  1. NEW DRGX S DRGX=0 F S DRGX=$O(DRG("AD",DRGX)) Q:'DRGX D PIVAD
  1. SOL ;
  1. NEW NAME
  1. S DRGX=0 F S DRGX=$O(DRG("SOL",DRGX)) Q:'DRGX D
  1. . D NAME(DRG("SOL",DRGX),34,.NAME,0) ; #373 Changed length to 34 from 39
  1. . W:($D(DRG("AD",1))!(DRGX>1)) ! W:DRGX=1 ?9,"in "
  1. . ;F X=0:0 S X=$O(NAME(X)) Q:'X W ?12 W NAME(X) I X=1,DRGX=1,'$D(DRG("AD",1)) D PIV1 ;#373
  1. . F X=0:0 S X=$O(NAME(X)) Q:'X W:X'=1 ! W ?12 W NAME(X) D:PIV2PRT RENEWDT D ;#373
  1. .. I X=1,DRGX=1,'$D(DRG("AD",1)) D PIV2 ;#373
  1. I 'RNDTPRT,$G(ND14)]"" W ! D RENEWDT
  1. Q
  1. PIVAD ; Print IV Additives.
  1. NEW NAME,PSGX
  1. D NAME(DRG("AD",DRGX),34,.NAME,1) ; #373 Changed length to 34 from 39
  1. ;F PSGX=0:0 S PSGX=$O(NAME(PSGX)) Q:'PSGX W:(DRGX'=1!(PSGX'=1)) ! W ?9,NAME(PSGX) I PSGX=1,DRGX=1 D PIV1 ;#373
  1. F PSGX=0:0 S PSGX=$O(NAME(PSGX)) Q:'PSGX W:(DRGX'=1!(PSGX'=1)) ! W ?9,NAME(PSGX) D:(DRGX=2!(PSGX=2)) RENEWDT I PSGX=1,DRGX=1 D PIV2 ;#373
  1. Q
  1. ;
  1. PIV1 ; Print Sched type, start/stop dates, and status.
  1. F X=2,3 S P(X)=$E($$ENDTC^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:5))
  1. ; #373 fields in PIV1 should line up with new columns in PIV2
  1. ;I '$D(PSJEXTP) W ?50,TYP,?53,P(2),?60,P(3),?67,$S($G(P(25))]"":P(25),1:P(17)) Q
  1. ;W ?50,TYP,?53,P(2),?63,P(3),?73,$S($G(P(25))]"":P(25),1:P(17))
  1. I '$D(PSJEXTP) W ?46,TYP,?49,P(2),?60,P(3),?71,$S($G(P(25))]"":P(25),1:P(17)) Q
  1. W ?46,TYP,?49,P(2),?60,P(3),?71,$S($G(P(25))]"":P(25),1:P(17))
  1. Q
  1. PIV2 ; Print Sched type, start/stop dates with four digit year, and status. ;#373
  1. F X=2,3 S P(X)=$E($$ENDTC2^PSGMI(P(X)),1,$S($D(PSJEXTP):10,1:10))
  1. I '$D(PSJEXTP) W ?46,TYP,?49,P(2),?60,P(3),?71,$S($G(P(25))]"":P(25),1:P(17)) S PIV2PRT=1 Q
  1. W ?46,TYP,?49,P(2),?60,P(3),?71,$S($G(P(25))]"":P(25),1:P(17)) S PIV2PRT=1
  1. Q
  1. RENEWDT ; 373 - Put renewal date on 2nd line instead of 1st.
  1. Q:$G(ND14)="" Q:RNDTPRT S ND14=$$ENDTC2^PSGMI(ND14)
  1. W ?49,"Renewed: ",$P(ND14," ") S RNDTPRT=1
  1. Q
  1. 59 ; Validate the Infusion rate entered using IV Quick order code.
  1. N I F I=2,3,5,7,8,9,11,15,23 S P(I)=""
  1. S P(4)="A",P(8)=$P($G(^PS(57.1,PSJQO,1)),U,5)
  1. I $G(^PS(57.1,PSJQO,4,1,0)) S DRG("SOL",1)=^(0),DRG("SOL",0)=1
  1. I X["?" S F1=53.1,F2=59 D ENHLP^PSIVORC1 G 59
  1. I X]"" D ENI^PSIVSP S:$D(X) P(8)=X
  1. K F1,F2
  1. Q
  1. WRTDRG(X,L) ; Format and print drug name, strength and bottle no.
  1. N Y S Y=" "_$P(X,U,3) S:$P(X,U,4) Y=Y_" ("_$P(X,U,4)_")"
  1. Q $E($P(X,U,2),1,(L-$L(Y)))_Y
  1. ;
  1. NAME(X,L,MARX,AD) ; Format Additive display.
  1. ;INPUT : X=DRG("AD",DRG) L=Display length AD=for Additive(1/0)
  1. ;OUTPUT: AD(X) if X=2 that means there is a second line to display
  1. N Y K MARX S Y=$P(X,U,3) S:(AD&($P(X,U,4)]"")) Y=Y_" ("_$P(X,U,4)_")"
  1. ;* S:'AD Y=Y_" "_$S(P(4)="P"!($G(P(23))="P")!$G(P(5)):P(9),1:$P(P(8),"@"))
  1. I 'AD!('$O(DRG("SOL",0))) D
  1. .I $G(PSJL)[" in" S Y=Y_" "_$S(P(4)="P"!($G(P(23))="P")!$G(P(5)):P(9),1:$P(P(8),"@")) Q
  1. .I $G(DRGX)]"",DRGX'>1 S Y=Y_" "_$S(P(4)="P"!($G(P(23))="P")!$G(P(5)):P(9),1:$P(P(8),"@")) Q
  1. ;I ($L($P(X,U,2))+$L(Y)+1)>L S NAME(1)=$P(X,U,2),NAME(2)=" "_Y Q
  1. I ($L($P(X,U,2))+$L(Y)+1)>L D TXT^PSGMUTL($P(X,U,2)_" "_Y,L) S:AD MARX(2)=" "_MARX(2) Q
  1. S MARX(1)=$P(X,U,2)_" "_Y
  1. Q
  1. ;
  1. INTERVAL(IVAR) ;
  1. N P,X,PSGOES M P=IVAR S X=$G(P(9)),PSGOES=1
  1. D EN^PSIVSP S IVAR(15)=$S($G(P(15)):P(15),1:1440)
  1. Q IVAR(15)
  1. ;
  1. DOW(SCHED) ;
  1. Q:SCHED="" 0
  1. N P9,PSIVX,X S PSIVX=0 S P9=SCHED
  1. ; Use schedule validator
  1. S X=SCHED D DW^PSGS0 I $G(X)="" Q 0
  1. I +$O(^PS(51.1,"APPSJ",SCHED,0)) S PSIVX=1 S P9=$P(SCHED,"@") F X=1:1:$L(P9,"-") D Q:'$G(PSIVX)
  1. . I '("MON,TUE,WED,THU,FRI,SAT,SUN"[$P(P9,"-",X)) S PSIVX=0 Q
  1. Q:PSIVX +PSIVX
  1. I '$D(^PS(51.1,"APPSJ",SCHED)) S PSIVX=1,P9=$P(SCHED,"@") F X=1:1:$L(P9,"-") D Q:'$G(PSIVX)
  1. . I '(",MO,TU,WE,TH,FR,SA,SU,"[(","_$P(P9,"-",X)_",")) S PSIVX=0 Q
  1. Q +PSIVX
  1. ;
  1. GETP(ON) ; Populate P array with data from order ON
  1. I ON["P" S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U) D
  1. .I $G(PSJCLOR) N ND2 S ND2=$G(^PS(53.1,+ON,2)) S P(2)=$P(ND2,"^",2),P(3)=$P(ND2,"^",4) S TYP=$P(^PS(53.1,+ON,0),"^",7)
  1. Q
  1. GTNUMLBL(DFN,ON) ; Get Number of Labels Per Day
  1. Q:'$G(DFN) Q:'$G(ON)
  1. S:'$D(P("NUMLBL")) P("NUMLBL")=$S(($G(^PS(55,DFN,"IV",+ON55,11))?1.N):+$G(^(11)),($G(P(8))]""):$P($G(P(8)),"@",2),1:"")
  1. S:(P("NUMLBL")'?1.N) P("NUMLBL")=""
  1. N PSJABBIN S PSJABBIN=$P($G(P(8)),"@") D
  1. .Q:(PSJABBIN?1"INFUSE OVER "1.N1" MINUTES")
  1. .D EXPINF^PSIVEDT1(.PSJABBIN,1) S P(8)=PSJABBIN_$S($G(P("NUMLBL"))?1.N:"@"_P("NUMLBL"),1:"")
  1. Q