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