PSIVQUI ;BIR/RGY,MLM - HANDLE QUICK CODE ENTRIES ;15 Dec 98 / 8:29 AM
;;5.0;INPATIENT MEDICATIONS;**21,50,65,73,76,93,104,110,275,256,377**;16 DEC 97;Build 2
;
;Reference to ^PS(51.1 is supported by DBIA 2177
;Reference to ^PS(51.2 is supported by DBIA 2178
;Reference to ^PS(52.6 is supported by DBIA 1231
;Reference to ^PS(52.7 is supported by DBIA 2173
;
N X,PSIVSC1 S (PSIVAT,PSIVAAT,PSIVWAT)="",PSIVQUIY=Y,(X,PSIVQUIX)=PSIVX
Q:'Y!(PSIVQUIX="") S PSIVX0=$O(^PS(52.6,"C",X,+Y,0)),PSIVX0=$G(^PS(52.6,+Y,1,PSIVX0,0))
I $P(PSIVX0,"^",5)]""!$P(PSIVX0,"^",6)!(P(5)) S PSIVAAT=$P(PSIVX0,"^",6)
K PSIVX0 S Y=PSIVQUIY,Y(0)=$G(^PS(52.6,+Y,0)),X=PSIVQUIX
Q:$S('$D(X):1,'$D(^PS(52.6,"C",X)):1,1:0)!'$D(P(4))
SET K DRG S PSIVX0=$S($D(^PS(52.6,+Y,1,+$O(^PS(52.6,"C",X,+Y,0)),0)):^(0),1:""),(DRGI,DRG("AD",0))=1,TDRG("AD",+Y,DRGI)="",DRG("AD",DRGI)=+Y_U_$P(Y(0),U)_U_$P(PSIVX0,"^",2)_U_U_$P(Y(0),U,13)_U_$P(Y(0),U,11)
N PSIVQZ,PSIVADD0,PSIVSZ,PSIVAZ,PSIVXAT,PSIVSIEN,PSIVXW S PSIVSIEN=0
;*** PSJ*5*256
I $P(PSIVX0,"^",5)]"" D Q:$G(PSGORQF)
. NEW PSJOLDNM
. S PSJOLDNM("ORD_SCHD")=$P(PSIVX0,"^",5)
. I $$CHKSCHD^PSJMISC2(.PSJOLDNM) S PSGORQF=1,DONE=1 Q
. S:$G(PSJOLDNM("NEW_SCHD"))]"" $P(PSIVX0,"^",5)=PSJOLDNM("NEW_SCHD"),$P(PSIVX0,"^",6)=""
. S P(9)=$P(PSIVX0,"^",5) ;377
I $P(PSIVX0,U,4)]"" S P("OPI")=$P(PSIVX0,U,4) K ^PS(53.45,+$G(PSJSYSP),6) S ^PS(53.45,+$G(PSJSYSP),6,0)="^^1^1^",^(1,0)=P("OPI")
I $P(PSIVX0,U,7)?1N.N D Q:$G(PSGORQF)
. S ND=$G(^PS(52.7,$P(PSIVX0,U,7),0))
. W !!,"SOLUTION: ",$P(ND,U),!
. N FIL S FIL="52.7",DRGTMP=$P(PSIVX0,U,7) D ORDERCHK^PSIVEDRG(DFN,ON55,1)
. I $G(PSGORQF) S X="^",DONE=1 Q
. S DRG("SOL",0)=1,DRG("SOL",1)=$P(PSIVX0,U,7)_U_$P(ND,U)_U_$P(ND,U,3)_U_U_$P(ND,U,13)_U_$P(ND,U,11),TDRG("SOL",$P(PSIVX0,U,7),1)=""
I $P(PSIVX0,U,5)]""!P(5) S X=$P(PSIVX0,U,5)
S PSIVQZ=$P(PSIVX0,U,5),PSIVQAZ=$P(PSIVX0,U,6),PSIVADD0=$G(^PS(52.6,+PSIVQUIY,0)),X=PSIVQZ
S PSIVSZ=$P(PSIVADD0,"^",5),PSIVAZ=$P(PSIVADD0,"^",6)
S PSIVAAT=$S(PSIVQZ]""&(PSIVQAZ]""):PSIVQAZ,PSIVQZ=""&(PSIVSZ]""):PSIVAZ,PSIVQZ=PSIVSZ:PSIVAZ,1:"")
I $P(PSIVX0,U,5)']""!P(5) S X=$S(X]"":X,1:$P($G(^PS(52.6,+PSIVQUIY,0)),"^",5))
;
; If a sched was found, check all matching schedules
; in 51.1 against $P(PSIVX0,"^",5), PSIVAAT, PSIVWAT
I PSIVQZ]"",$G(X)'="" S ZZ=0 D
.;if ZZ sched/times matches quick code sched/times, use the schedule
.F S ZZ=$O(^PS(51.1,"AC","PSJ",X,ZZ)) Q:'ZZ!PSIVSIEN D Q:PSIVSIEN
..N PSIVXAT S PSIVXAT=$P(^PS(51.1,ZZ,0),"^",2) Q:PSIVXAT=""
..I PSIVXAT=$P(PSIVX0,"^",6) S PSIVAT=$P(PSIVX0,"^",6),PSIVSIEN=ZZ
;
; If quick code has no schedule, check IV additive
I PSIVAT="",$P(PSIVX0,"^",5)="",$G(X)'="" S ZZ=0 D
.F S ZZ=$O(^PS(51.1,"AC","PSJ",X,ZZ)) Q:'ZZ!PSIVSIEN D Q:PSIVSIEN
..N PSIVXAT S PSIVXAT=$P(^PS(51.1,ZZ,0),"^",2) Q:PSIVXAT=""
..I PSIVAAT=PSIVXAT,(X=PSIVSZ) S PSIVAT=PSIVAAT,PSIVSIEN=ZZ
.I PSIVAT="",PSIVAAT]"" S PSIVAT=PSIVAAT,$P(PSIVX0,"^",6)=PSIVAAT,$P(PSIVX0,"^",5)=PSIVSZ,PSIVSIEN=-1
;
; If quick code has schedule, no admin times, use ward times
I PSIVAT="",PSIVQZ]"",$G(X)'="" D
.S PSIVXW=$S($G(WSCHADM):WSCHADM,$G(VAIN(4)):+VAIN(4),1:"") Q:'PSIVXW
.S ZZ=0 F S ZZ=$O(^PS(51.1,"AC","PSJ",X,ZZ)) Q:'ZZ!PSIVSIEN D Q:PSIVSIEN
..N PSIVXAT S PSIVXAT=$P(^PS(51.1,ZZ,0),"^",2) Q:PSIVXAT=""
..S PSIVWAT=$P($G(^PS(51.1,ZZ,1,+PSIVXW,0)),"^",2)
..I PSIVWAT]"" S PSIVAT=PSIVWAT,PSIVSIEN=ZZ
;
; No ward times; go back to IV additive. If quick code has schedule,
; make sure it matches IV additive
I PSIVAT="",PSIVAAT]"",PSIVWAT="",$G(X) D
.S ZZ=0 F S ZZ=$O(^PS(51.1,"AC","PSJ",X,ZZ)) Q:'ZZ!PSIVSIEN D Q:PSIVSIEN
..N PSIVXAT S PSIVXAT=$P(^PS(51.1,ZZ,0),"^",2) Q:PSIVXAT=""
..I (PSIVQZ=X&(PSIVQZ=PSIVSZ))!(PSIVQZ=""&(PSIVSZ]"")) I PSIVXAT=PSIVAAT D Q
...S PSIVAT=PSIVAAT,PSIVSIEN=ZZ
.I PSIVAT="" S PSIVAT=PSIVAAT,$P(PSIVX0,"^",6)=PSIVAAT,$P(PSIVX0,"^",5)=X,PSIVSIEN=-1
I $G(PSIVSIEN) S Y=$S(PSIVSIEN>0:PSIVSIEN,1:"") N PSGOES S PSGOES=1
I X="" S (Y,PSIVQUIY)=""
S PSIVSPQF=1 D EN^PSIVSP K PSIVSPQF
S P(11)=$S($G(PSGS0Y)]"":PSGS0Y,$P(PSIVX0,"^",6)]"":$P(PSIVX0,"^",6),(PSIVQZ]""&(PSIVWAT]"")):PSIVWAT,PSIVAAT]"":PSIVAAT,$G(P(11))]"":$G(P(11)),1:PSIVAT)
S X=$P(PSIVX0,"^",3)
I $P(PSIVX0,U,8) D
.S P("MR")=+$P(PSIVX0,U,8)_U_$S($P($G(^PS(51.2,+$P(PSIVX0,U,8),0)),U,3):$P($G(^PS(51.2,+$P(PSIVX0,U,8),0)),U,3),1:$E($P($G(^PS(51.2,+$P(PSIVX0,U,8),0)),U),1,5))
W " ",X D ENI^PSIVSP I '$D(X) W $C(7)," --> Invalid infusion rate !!" I '$$SCHREQ^PSJLIVFD(.P) S P(15)=0
I $$SCHREQ^PSJLIVFD(.P),'$$DOW^PSIVUTL($G(P(9))),'(P(15)>0) S P(15)=$$INTERVAL^PSIVUTL(.P)
S PSIVOK="57^58^59^3^26^39^63^64^"_$S($E(P("OT"))="I":"101^109^",1:"")_"10^25^1"
S P(17)="A",P(8)=$S($D(X):X,1:""),PSIVE=0,PSIVSTR="QUICK CODE",(DRG(2),Y)="",EDIT=$S(+P("MR"):"",1:"3^")_$P(EDIT,"64^",2) K ND,PSIVX0,PSIVSC,PSIVX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVQUI 4855 printed Apr 09, 2024@21:07:48 Page 2
PSIVQUI ;BIR/RGY,MLM - HANDLE QUICK CODE ENTRIES ;15 Dec 98 / 8:29 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**21,50,65,73,76,93,104,110,275,256,377**;16 DEC 97;Build 2
+2 ;
+3 ;Reference to ^PS(51.1 is supported by DBIA 2177
+4 ;Reference to ^PS(51.2 is supported by DBIA 2178
+5 ;Reference to ^PS(52.6 is supported by DBIA 1231
+6 ;Reference to ^PS(52.7 is supported by DBIA 2173
+7 ;
+8 NEW X,PSIVSC1
SET (PSIVAT,PSIVAAT,PSIVWAT)=""
SET PSIVQUIY=Y
SET (X,PSIVQUIX)=PSIVX
+9 if 'Y!(PSIVQUIX="")
QUIT
SET PSIVX0=$ORDER(^PS(52.6,"C",X,+Y,0))
SET PSIVX0=$GET(^PS(52.6,+Y,1,PSIVX0,0))
+10 IF $PIECE(PSIVX0,"^",5)]""!$PIECE(PSIVX0,"^",6)!(P(5))
SET PSIVAAT=$PIECE(PSIVX0,"^",6)
+11 KILL PSIVX0
SET Y=PSIVQUIY
SET Y(0)=$GET(^PS(52.6,+Y,0))
SET X=PSIVQUIX
+12 if $SELECT('$DATA(X)
QUIT
SET KILL DRG
SET PSIVX0=$SELECT($DATA(^PS(52.6,+Y,1,+$ORDER(^PS(52.6,"C",X,+Y,0)),0)):^(0),1:"")
SET (DRGI,DRG("AD",0))=1
SET TDRG("AD",+Y,DRGI)=""
SET DRG("AD",DRGI)=+Y_U_$PIECE(Y(0),U)_U_$PIECE(PSIVX0,"^",2)_U_U_$PIECE(Y(0),U,13)_U_$PIECE(Y(0),U,11)
+1 NEW PSIVQZ,PSIVADD0,PSIVSZ,PSIVAZ,PSIVXAT,PSIVSIEN,PSIVXW
SET PSIVSIEN=0
+2 ;*** PSJ*5*256
+3 IF $PIECE(PSIVX0,"^",5)]""
Begin DoDot:1
+4 NEW PSJOLDNM
+5 SET PSJOLDNM("ORD_SCHD")=$PIECE(PSIVX0,"^",5)
+6 IF $$CHKSCHD^PSJMISC2(.PSJOLDNM)
SET PSGORQF=1
SET DONE=1
QUIT
+7 if $GET(PSJOLDNM("NEW_SCHD"))]""
SET $PIECE(PSIVX0,"^",5)=PSJOLDNM("NEW_SCHD")
SET $PIECE(PSIVX0,"^",6)=""
+8 ;377
SET P(9)=$PIECE(PSIVX0,"^",5)
End DoDot:1
if $GET(PSGORQF)
QUIT
+9 IF $PIECE(PSIVX0,U,4)]""
SET P("OPI")=$PIECE(PSIVX0,U,4)
KILL ^PS(53.45,+$GET(PSJSYSP),6)
SET ^PS(53.45,+$GET(PSJSYSP),6,0)="^^1^1^"
SET ^(1,0)=P("OPI")
+10 IF $PIECE(PSIVX0,U,7)?1N.N
Begin DoDot:1
+11 SET ND=$GET(^PS(52.7,$PIECE(PSIVX0,U,7),0))
+12 WRITE !!,"SOLUTION: ",$PIECE(ND,U),!
+13 NEW FIL
SET FIL="52.7"
SET DRGTMP=$PIECE(PSIVX0,U,7)
DO ORDERCHK^PSIVEDRG(DFN,ON55,1)
+14 IF $GET(PSGORQF)
SET X="^"
SET DONE=1
QUIT
+15 SET DRG("SOL",0)=1
SET DRG("SOL",1)=$PIECE(PSIVX0,U,7)_U_$PIECE(ND,U)_U_$PIECE(ND,U,3)_U_U_$PIECE(ND,U,13)_U_$PIECE(ND,U,11)
SET TDRG("SOL",$PIECE(PSIVX0,U,7),1)=""
End DoDot:1
if $GET(PSGORQF)
QUIT
+16 IF $PIECE(PSIVX0,U,5)]""!P(5)
SET X=$PIECE(PSIVX0,U,5)
+17 SET PSIVQZ=$PIECE(PSIVX0,U,5)
SET PSIVQAZ=$PIECE(PSIVX0,U,6)
SET PSIVADD0=$GET(^PS(52.6,+PSIVQUIY,0))
SET X=PSIVQZ
+18 SET PSIVSZ=$PIECE(PSIVADD0,"^",5)
SET PSIVAZ=$PIECE(PSIVADD0,"^",6)
+19 SET PSIVAAT=$SELECT(PSIVQZ]""&(PSIVQAZ]""):PSIVQAZ,PSIVQZ=""&(PSIVSZ]""):PSIVAZ,PSIVQZ=PSIVSZ:PSIVAZ,1:"")
+20 IF $PIECE(PSIVX0,U,5)']""!P(5)
SET X=$SELECT(X]"":X,1:$PIECE($GET(^PS(52.6,+PSIVQUIY,0)),"^",5))
+21 ;
+22 ; If a sched was found, check all matching schedules
+23 ; in 51.1 against $P(PSIVX0,"^",5), PSIVAAT, PSIVWAT
+24 IF PSIVQZ]""
IF $GET(X)'=""
SET ZZ=0
Begin DoDot:1
+25 ;if ZZ sched/times matches quick code sched/times, use the schedule
+26 FOR
SET ZZ=$ORDER(^PS(51.1,"AC","PSJ",X,ZZ))
if 'ZZ!PSIVSIEN
QUIT
Begin DoDot:2
+27 NEW PSIVXAT
SET PSIVXAT=$PIECE(^PS(51.1,ZZ,0),"^",2)
if PSIVXAT=""
QUIT
+28 IF PSIVXAT=$PIECE(PSIVX0,"^",6)
SET PSIVAT=$PIECE(PSIVX0,"^",6)
SET PSIVSIEN=ZZ
End DoDot:2
if PSIVSIEN
QUIT
End DoDot:1
+29 ;
+30 ; If quick code has no schedule, check IV additive
+31 IF PSIVAT=""
IF $PIECE(PSIVX0,"^",5)=""
IF $GET(X)'=""
SET ZZ=0
Begin DoDot:1
+32 FOR
SET ZZ=$ORDER(^PS(51.1,"AC","PSJ",X,ZZ))
if 'ZZ!PSIVSIEN
QUIT
Begin DoDot:2
+33 NEW PSIVXAT
SET PSIVXAT=$PIECE(^PS(51.1,ZZ,0),"^",2)
if PSIVXAT=""
QUIT
+34 IF PSIVAAT=PSIVXAT
IF (X=PSIVSZ)
SET PSIVAT=PSIVAAT
SET PSIVSIEN=ZZ
End DoDot:2
if PSIVSIEN
QUIT
+35 IF PSIVAT=""
IF PSIVAAT]""
SET PSIVAT=PSIVAAT
SET $PIECE(PSIVX0,"^",6)=PSIVAAT
SET $PIECE(PSIVX0,"^",5)=PSIVSZ
SET PSIVSIEN=-1
End DoDot:1
+36 ;
+37 ; If quick code has schedule, no admin times, use ward times
+38 IF PSIVAT=""
IF PSIVQZ]""
IF $GET(X)'=""
Begin DoDot:1
+39 SET PSIVXW=$SELECT($GET(WSCHADM):WSCHADM,$GET(VAIN(4)):+VAIN(4),1:"")
if 'PSIVXW
QUIT
+40 SET ZZ=0
FOR
SET ZZ=$ORDER(^PS(51.1,"AC","PSJ",X,ZZ))
if 'ZZ!PSIVSIEN
QUIT
Begin DoDot:2
+41 NEW PSIVXAT
SET PSIVXAT=$PIECE(^PS(51.1,ZZ,0),"^",2)
if PSIVXAT=""
QUIT
+42 SET PSIVWAT=$PIECE($GET(^PS(51.1,ZZ,1,+PSIVXW,0)),"^",2)
+43 IF PSIVWAT]""
SET PSIVAT=PSIVWAT
SET PSIVSIEN=ZZ
End DoDot:2
if PSIVSIEN
QUIT
End DoDot:1
+44 ;
+45 ; No ward times; go back to IV additive. If quick code has schedule,
+46 ; make sure it matches IV additive
+47 IF PSIVAT=""
IF PSIVAAT]""
IF PSIVWAT=""
IF $GET(X)
Begin DoDot:1
+48 SET ZZ=0
FOR
SET ZZ=$ORDER(^PS(51.1,"AC","PSJ",X,ZZ))
if 'ZZ!PSIVSIEN
QUIT
Begin DoDot:2
+49 NEW PSIVXAT
SET PSIVXAT=$PIECE(^PS(51.1,ZZ,0),"^",2)
if PSIVXAT=""
QUIT
+50 IF (PSIVQZ=X&(PSIVQZ=PSIVSZ))!(PSIVQZ=""&(PSIVSZ]""))
IF PSIVXAT=PSIVAAT
Begin DoDot:3
+51 SET PSIVAT=PSIVAAT
SET PSIVSIEN=ZZ
End DoDot:3
QUIT
End DoDot:2
if PSIVSIEN
QUIT
+52 IF PSIVAT=""
SET PSIVAT=PSIVAAT
SET $PIECE(PSIVX0,"^",6)=PSIVAAT
SET $PIECE(PSIVX0,"^",5)=X
SET PSIVSIEN=-1
End DoDot:1
+53 IF $GET(PSIVSIEN)
SET Y=$SELECT(PSIVSIEN>0:PSIVSIEN,1:"")
NEW PSGOES
SET PSGOES=1
+54 IF X=""
SET (Y,PSIVQUIY)=""
+55 SET PSIVSPQF=1
DO EN^PSIVSP
KILL PSIVSPQF
+56 SET P(11)=$SELECT($GET(PSGS0Y)]"":PSGS0Y,$PIECE(PSIVX0,"^",6)]"":$PIECE(PSIVX0,"^",6),(PSIVQZ]""&(PSIVWAT]"")):PSIVWAT,PSIVAAT]"":PSIVAAT,$GET(P(11))]"":$GET(P(11)),1:PSIVAT)
+57 SET X=$PIECE(PSIVX0,"^",3)
+58 IF $PIECE(PSIVX0,U,8)
Begin DoDot:1
+59 SET P("MR")=+$PIECE(PSIVX0,U,8)_U_$SELECT($PIECE($GET(^PS(51.2,+$PIECE(PSIVX0,U,8),0)),U,3):$PIECE($GET(^PS(51.2,+$PIECE(PSIVX0,U,8),0)),U,3),1:$EXTRACT($PIECE($GET(^PS(51.2,+$PIECE(PSIVX0,U,8),0)),U),1,5))
End DoDot:1
+60 WRITE " ",X
DO ENI^PSIVSP
IF '$DATA(X)
WRITE $CHAR(7)," --> Invalid infusion rate !!"
IF '$$SCHREQ^PSJLIVFD(.P)
SET P(15)=0
+61 IF $$SCHREQ^PSJLIVFD(.P)
IF '$$DOW^PSIVUTL($GET(P(9)))
IF '(P(15)>0)
SET P(15)=$$INTERVAL^PSIVUTL(.P)
+62 SET PSIVOK="57^58^59^3^26^39^63^64^"_$SELECT($EXTRACT(P("OT"))="I":"101^109^",1:"")_"10^25^1"
+63 SET P(17)="A"
SET P(8)=$SELECT($DATA(X):X,1:"")
SET PSIVE=0
SET PSIVSTR="QUICK CODE"
SET (DRG(2),Y)=""
SET EDIT=$SELECT(+P("MR"):"",1:"3^")_$PIECE(EDIT,"64^",2)
KILL ND,PSIVX0,PSIVSC,PSIVX
+64 QUIT
