PSJORAPI ;BIR/LDT-API utility routine ;7/8/00
;;5.0; INPATIENT MEDICATIONS ;**48**;16 DEC 1997
;
; Reference to ^PSDRUG is supported by DBIA 2192.
; Reference to ^PS(52.6 is supported by DBIA 1231.
; Reference to ^PS(52.7 is supported by DBIA 2173.
; Reference to ^PS(55 is supported by DBIA 2191.
;
EN(PSJB,PSJE,PSJX,PSJDT,PSJN) ;
;PSJB - begin date
;PSJE - end date
;PSJX - medication array
;PSJDT - fill date (not used by Inaptient)
;PSJN - node subscript
;
N PSJRD,PSJDRG,PSJND,PSJPDFN,PSJCX,PSJMED1,PSJMED2,PSJDNM,PSJBEG,PSJEND,PSJSTRT,PSJSTP
Q:'$G(PSJB)!('$G(PSJE))
Q:$G(PSJN)=""
K ^TMP(PSJN,$J),^TMP($J,"PSJCT")
UD ;Check for Unit Dose orders
N PSJND2,PSJORD,PSJDDRG
S PSJBEG=PSJB-.0001,PSJEND=PSJE+.999999
F S PSJBEG=$O(^PS(55,"AUDS",PSJBEG)) Q:'PSJBEG!(PSJBEG>PSJEND) S PSJPDFN=0 F S PSJPDFN=$O(^PS(55,"AUDS",PSJBEG,PSJPDFN)) Q:'PSJPDFN D
. S PSJORD=0 F S PSJORD=$O(^PS(55,"AUDS",PSJBEG,PSJPDFN,PSJORD)) Q:'PSJORD D
.. S PSJND2=$G(^PS(55,PSJPDFN,5,PSJORD,2)),PSJSTRT=$P(PSJND2,"^",2),PSJSTP=$P(PSJND2,"^",4)
.. S PSJDDRG=0 F S PSJDDRG=$O(^PS(55,PSJPDFN,5,PSJORD,1,PSJDDRG)) Q:'PSJDDRG S PSJDRG=+$G(^PS(55,PSJPDFN,5,PSJORD,1,PSJDDRG,0)),PSJND=+$G(^PSDRUG(+PSJDRG,"ND")),PSJDNM=$P($G(^(0)),"^") D MED
IV ;Check for IV orders
N PSJND0,PSJORD,PSJDDRG,FIL,DRG,DRGTYP
S PSJBEG=PSJB-.0001,PSJEND=PSJE+.999999
F S PSJBEG=$O(^PS(55,"AIVS",PSJBEG)) Q:'PSJBEG!(PSJBEG>PSJEND) S PSJPDFN=0 F S PSJPDFN=$O(^PS(55,"AIVS",PSJBEG,PSJPDFN)) Q:'PSJPDFN D
. S PSJORD=0 F S PSJORD=$O(^PS(55,"AIVS",PSJBEG,PSJPDFN,PSJORD)) Q:'PSJORD D
.. S PSJND0=$G(^PS(55,PSJPDFN,"IV",PSJORD,0)),PSJSTRT=$P(PSJND0,"^",2),PSJSTP=$P(PSJND0,"^",3)
.. F DRGTYP="AD","SOL" F DRG=0:0 S DRG=$O(^PS(55,PSJPDFN,"IV",PSJORD,DRGTYP,DRG)) Q:'DRG D
... S PSJDDRG=+$G(^PS(55,PSJPDFN,"IV",PSJORD,DRGTYP,DRG,0)),FIL=$S(DRGTYP="AD":52.6,1:52.7),PSJDRG=$P($G(^PS(FIL,+PSJDDRG,0)),"^",2),PSJND=+$G(^PSDRUG(+PSJDRG,"ND")),PSJDNM=$P($G(^(0)),"^") D MED
G END
Q
;
MED ;Check medication array for matches
K PSJMED1,PSJMED2,PSJMED3
I $D(PSJX(PSJDRG_";PSDRUG(")) S PSJMED1=1 D MEDS Q
I $G(PSJND),$D(PSJX(PSJND_";PSNDF(50.6,")) S PSJMED2=1 D MEDS Q
;Here, add class check when ready, use PSJMED2 for NDF, default to 1 for VA Class in MEDS
Q
MEDS I $D(^TMP($J,"PSJCT",PSJPDFN)) S (PSJCX,^TMP($J,"PSJCT",PSJPDFN))=^TMP($J,"PSJCT",PSJPDFN)+1
I '$D(^TMP($J,"PSJCT",PSJPDFN)) S (PSJCX,^TMP($J,"PSJCT",PSJPDFN))=1
S ^TMP(PSJN,$J,PSJPDFN,PSJCX,0)=$S($G(PSJMED1):PSJDRG_";PSDRUG(",1:$G(PSJND)_";PSNDF(50.6,")
S ^TMP(PSJN,$J,PSJPDFN,PSJCX,1)=$G(PSJSTRT)_"^^"_$G(PSJDNM)_"^^"_$G(PSJSTP)
Q
END ;
K ^TMP($J,"PSJCT")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJORAPI 2667 printed Sep 23, 2025@19:44:22 Page 2
PSJORAPI ;BIR/LDT-API utility routine ;7/8/00
+1 ;;5.0; INPATIENT MEDICATIONS ;**48**;16 DEC 1997
+2 ;
+3 ; Reference to ^PSDRUG is supported by DBIA 2192.
+4 ; Reference to ^PS(52.6 is supported by DBIA 1231.
+5 ; Reference to ^PS(52.7 is supported by DBIA 2173.
+6 ; Reference to ^PS(55 is supported by DBIA 2191.
+7 ;
EN(PSJB,PSJE,PSJX,PSJDT,PSJN) ;
+1 ;PSJB - begin date
+2 ;PSJE - end date
+3 ;PSJX - medication array
+4 ;PSJDT - fill date (not used by Inaptient)
+5 ;PSJN - node subscript
+6 ;
+7 NEW PSJRD,PSJDRG,PSJND,PSJPDFN,PSJCX,PSJMED1,PSJMED2,PSJDNM,PSJBEG,PSJEND,PSJSTRT,PSJSTP
+8 if '$GET(PSJB)!('$GET(PSJE))
QUIT
+9 if $GET(PSJN)=""
QUIT
+10 KILL ^TMP(PSJN,$JOB),^TMP($JOB,"PSJCT")
UD ;Check for Unit Dose orders
+1 NEW PSJND2,PSJORD,PSJDDRG
+2 SET PSJBEG=PSJB-.0001
SET PSJEND=PSJE+.999999
+3 FOR
SET PSJBEG=$ORDER(^PS(55,"AUDS",PSJBEG))
if 'PSJBEG!(PSJBEG>PSJEND)
QUIT
SET PSJPDFN=0
FOR
SET PSJPDFN=$ORDER(^PS(55,"AUDS",PSJBEG,PSJPDFN))
if 'PSJPDFN
QUIT
Begin DoDot:1
+4 SET PSJORD=0
FOR
SET PSJORD=$ORDER(^PS(55,"AUDS",PSJBEG,PSJPDFN,PSJORD))
if 'PSJORD
QUIT
Begin DoDot:2
+5 SET PSJND2=$GET(^PS(55,PSJPDFN,5,PSJORD,2))
SET PSJSTRT=$PIECE(PSJND2,"^",2)
SET PSJSTP=$PIECE(PSJND2,"^",4)
+6 SET PSJDDRG=0
FOR
SET PSJDDRG=$ORDER(^PS(55,PSJPDFN,5,PSJORD,1,PSJDDRG))
if 'PSJDDRG
QUIT
SET PSJDRG=+$GET(^PS(55,PSJPDFN,5,PSJORD,1,PSJDDRG,0))
SET PSJND=+$GET(^PSDRUG(+PSJDRG,"ND"))
SET PSJDNM=$PIECE($GET(^(0)),"^")
DO MED
End DoDot:2
End DoDot:1
IV ;Check for IV orders
+1 NEW PSJND0,PSJORD,PSJDDRG,FIL,DRG,DRGTYP
+2 SET PSJBEG=PSJB-.0001
SET PSJEND=PSJE+.999999
+3 FOR
SET PSJBEG=$ORDER(^PS(55,"AIVS",PSJBEG))
if 'PSJBEG!(PSJBEG>PSJEND)
QUIT
SET PSJPDFN=0
FOR
SET PSJPDFN=$ORDER(^PS(55,"AIVS",PSJBEG,PSJPDFN))
if 'PSJPDFN
QUIT
Begin DoDot:1
+4 SET PSJORD=0
FOR
SET PSJORD=$ORDER(^PS(55,"AIVS",PSJBEG,PSJPDFN,PSJORD))
if 'PSJORD
QUIT
Begin DoDot:2
+5 SET PSJND0=$GET(^PS(55,PSJPDFN,"IV",PSJORD,0))
SET PSJSTRT=$PIECE(PSJND0,"^",2)
SET PSJSTP=$PIECE(PSJND0,"^",3)
+6 FOR DRGTYP="AD","SOL"
FOR DRG=0:0
SET DRG=$ORDER(^PS(55,PSJPDFN,"IV",PSJORD,DRGTYP,DRG))
if 'DRG
QUIT
Begin DoDot:3
+7 SET PSJDDRG=+$GET(^PS(55,PSJPDFN,"IV",PSJORD,DRGTYP,DRG,0))
SET FIL=$SELECT(DRGTYP="AD":52.6,1:52.7)
SET PSJDRG=$PIECE($GET(^PS(FIL,+PSJDDRG,0)),"^",2)
SET PSJND=+$GET(^PSDRUG(+PSJDRG,"ND"))
SET PSJDNM=$PIECE($GET(^(0)),"^")
DO MED
End DoDot:3
End DoDot:2
End DoDot:1
+8 GOTO END
+9 QUIT
+10 ;
MED ;Check medication array for matches
+1 KILL PSJMED1,PSJMED2,PSJMED3
+2 IF $DATA(PSJX(PSJDRG_";PSDRUG("))
SET PSJMED1=1
DO MEDS
QUIT
+3 IF $GET(PSJND)
IF $DATA(PSJX(PSJND_";PSNDF(50.6,"))
SET PSJMED2=1
DO MEDS
QUIT
+4 ;Here, add class check when ready, use PSJMED2 for NDF, default to 1 for VA Class in MEDS
+5 QUIT
MEDS IF $DATA(^TMP($JOB,"PSJCT",PSJPDFN))
SET (PSJCX,^TMP($JOB,"PSJCT",PSJPDFN))=^TMP($JOB,"PSJCT",PSJPDFN)+1
+1 IF '$DATA(^TMP($JOB,"PSJCT",PSJPDFN))
SET (PSJCX,^TMP($JOB,"PSJCT",PSJPDFN))=1
+2 SET ^TMP(PSJN,$JOB,PSJPDFN,PSJCX,0)=$SELECT($GET(PSJMED1):PSJDRG_";PSDRUG(",1:$GET(PSJND)_";PSNDF(50.6,")
+3 SET ^TMP(PSJN,$JOB,PSJPDFN,PSJCX,1)=$GET(PSJSTRT)_"^^"_$GET(PSJDNM)_"^^"_$GET(PSJSTP)
+4 QUIT
END ;
+1 KILL ^TMP($JOB,"PSJCT")
+2 QUIT
