PSJPDV1 ;BIR/KKA-LIST PATIENTS ON SPECIFIC DRUGS (CONT.) ;15 May 98 / 9:28 AM
;;5.0;INPATIENT MEDICATIONS;**3,33,58,267**;16 DEC 97;Build 158
;
; Reference to ^PS(55 supported by DBIA #2191.
;
S PG=1,(PREVNM,TMPNM)="",(PREVWD,TMPWD)="",WFLG=0
REC ;write patient and order information
D HEADING G:$D(QFLG) DONE
I '$D(^TMP("PSJ",$J)) W !!,"NO DATA FOUND" G DONE
S FST="" F S FST=$O(^TMP("PSJ",$J,FST)) Q:FST=""!($D(QFLG)) S SND="" F S SND=$O(^TMP("PSJ",$J,FST,SND)) Q:SND=""!($D(QFLG)) S ORD="" F S ORD=$O(^TMP("PSJ",$J,FST,SND,ORD)) Q:'ORD!($D(QFLG)) D
.; naked ref below refers to line above
.S ND=^(ORD),PER=$S(PSJSRT="P":FST,1:SND),STD=$S(PSJSRT="P":SND,1:FST)
.S WFLG=0,(NM,TMPNM)=$P(PER,";"),(WARD,TMPWD)=$P(ND,"^",2) I PSJSRT="P" S:(TMPNM=PREVNM)&(TMPWD=PREVWD) NM="",WFLG=1 I TMPNM'=PREVNM S PREVNM=NM W !
.S:TMPWD'=PREVWD PREVWD=WARD S (PSGP,IEN)=$P(PER,";",2),PSJJORD=+ORD D:ORD["V" IVREC Q:$D(QFLG) D:ORD'["V" UDREC Q:$D(QFLG)
;
DONE K ADCNT,CONT,FST,JJ,LCNT,LN,ND3,ND3FLG,ND4,ON,OPI,ORD,P,PER,PG,PREVNM,PEVWD,PRIMD,PSJAD,PSJSOL,RSTFLG,SI,SND,SOLCNT,SSN,TMPNM,TMPWD,WCNT,WFLG,WRD,WARD,RMBD,PSJ,DRGI,DRGN,DRGT
Q
;
UDREC ;write Unit Dose record
N X,PSJ K ND3FLG
D DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",30,30,.PSJ,0)
S RSTFLG=2,SSN=$P(ND,U),WARD=$P(ND,U,2),RMBD=$P(ND,U,3)
D:$Y+5>IOSL HEADING Q:$D(QFLG)
W !!,NM,?32,PSJ(1),?68,$E($$ENDTC^PSGMI(STD),1,5),?75,$E($$ENDTC^PSGMI($P(ND,U,6)),1,5),! W:'WFLG SSN
N X F X=1:0 S X=$O(PSJ(X)) Q:'X W ?32,PSJ(X) D THEREST I RSTFLG>3&($X>32) W !
N I S WCNT=1,SI=$P($G(^PS(55,PSGP,5,PSJJORD,6)),"^") I $TR(SI," ")]"" W:$X>31 ! F I=1:1:$L(SI," ") S WRD=$P(SI," ",I) Q:(I>1)&$P(SI," ",I-1,180)="" S WCNT=WCNT+1 D
.I $X+$L(WRD)>79 W ! I 'WFLG&('$D(ND3FLG)) W $P(ND,"^",3) S ND3FLG=1
.W ?31," ",WRD
I 'WFLG&('$D(ND3FLG)) W !,$P(ND,"^",3)
K ND3FLG
Q
IVREC ;write IV record
D:$Y+5>IOSL HEADING Q:$D(QFLG)
N DRG,P,PSG,ON55,PSJ
S RSTFLG=1,SSN=$P(ND,U),WARD=$P(ND,U,2),RMBD=$P(ND,U,3)
S DFN=PSGP,ON=PSJJORD D GT55^PSIVORFB
W !!,NM
N X F X=0:0 S X=$O(DRG("AD",X)) Q:'X D NAME^PSIVUTL(DRG("AD",X),30,.PSJ,1) F JJ=0:0 S JJ=$O(PSJ(JJ)) Q:'JJ W ?32,PSJ(JJ) D THEREST I RSTFLG>3&($X>32) W !
N X,PSJ F X=0:0 S X=$O(DRG("SOL",X)) Q:'X D NAME^PSIVUTL(DRG("SOL",X),30,.PSJ,0) N JJ F JJ=0:0 S JJ=$O(PSJ(JJ)) Q:'JJ W:JJ=1 ?33,"in " W ?36,PSJ(JJ) D THEREST I RSTFLG>3&($X>31) W !
W ?32,$P(P("MR"),U,2)_" "_P(9)_" "_P(8) D THEREST
S OPI=$P(P("OPI"),"^") I OPI]"" W:$X>31 ! F X=1:1:$L(OPI," ") S Y=$P(OPI," ",X) D THEREST W:$X+$L(Y)>80 ! W ?32,Y," "
F Q:RSTFLG>3 D THEREST
Q
THEREST ;
I RSTFLG=1 W ?68,$E($$ENDTC^PSGMI(STD),1,5),?75,$E($$ENDTC^PSGMI(P(3)),1,5),! W:'WFLG SSN
I RSTFLG=2 W ! W:'WFLG WARD
I RSTFLG=3 S ND3FLG=1 W ! W:'WFLG RMBD
S RSTFLG=RSTFLG+1
Q
HEADING I $E(IOST)'="P" W !,"Press RETURN to continue ""^"" to exit: " R CONT:DTIME S:CONT["^" QFLG=1 Q:$D(QFLG)
W:$Y @IOF
S NM=TMPNM,WFLG=0
W !,$E($$ENDTC^PSGMI(DT),1,8),?70,"PAGE: ",PG S PG=PG+1
S LN="LISTING OF PATIENTS WITH ORDERS CONTAINING "_$S(PSJSL="V":"VA CLASS(ES) OF DRUGS",PSJSL="O":"ORDERABLE ITEM(S)",PSJSL="D":"DISPENSE DRUG(S)")_":"
W !! D LINE W !
S LN="" F S LN=$O(PSJSNM(LN)) Q:LN="" W ! D LINE
S LN="FROM "_$$ENDTC^PSGMI(PSJREPS)_" TO "_$$ENDTC^PSGMI(PSJREPF) W !! D LINE W !!
F X=1:1:80 W "-"
W !?68,"Start",?75,"Stop",!,"Patient",?32,"Order",?68,"Date",?75,"Date",!
F X=1:1:80 W "-"
Q
LINE ;
W ?(80-$L(LN))/2,LN Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPDV1 3452 printed Sep 23, 2025@19:45:02 Page 2
PSJPDV1 ;BIR/KKA-LIST PATIENTS ON SPECIFIC DRUGS (CONT.) ;15 May 98 / 9:28 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**3,33,58,267**;16 DEC 97;Build 158
+2 ;
+3 ; Reference to ^PS(55 supported by DBIA #2191.
+4 ;
+5 SET PG=1
SET (PREVNM,TMPNM)=""
SET (PREVWD,TMPWD)=""
SET WFLG=0
REC ;write patient and order information
+1 DO HEADING
if $DATA(QFLG)
GOTO DONE
+2 IF '$DATA(^TMP("PSJ",$JOB))
WRITE !!,"NO DATA FOUND"
GOTO DONE
+3 SET FST=""
FOR
SET FST=$ORDER(^TMP("PSJ",$JOB,FST))
if FST=""!($DATA(QFLG))
QUIT
SET SND=""
FOR
SET SND=$ORDER(^TMP("PSJ",$JOB,FST,SND))
if SND=""!($DATA(QFLG))
QUIT
SET ORD=""
FOR
SET ORD=$ORDER(^TMP("PSJ",$JOB,FST,SND,ORD))
if 'ORD!($DATA(QFLG))
QUIT
Begin DoDot:1
+4 ; naked ref below refers to line above
+5 SET ND=^(ORD)
SET PER=$SELECT(PSJSRT="P":FST,1:SND)
SET STD=$SELECT(PSJSRT="P":SND,1:FST)
+6 SET WFLG=0
SET (NM,TMPNM)=$PIECE(PER,";")
SET (WARD,TMPWD)=$PIECE(ND,"^",2)
IF PSJSRT="P"
if (TMPNM=PREVNM)&(TMPWD=PREVWD)
SET NM=""
SET WFLG=1
IF TMPNM'=PREVNM
SET PREVNM=NM
WRITE !
+7 if TMPWD'=PREVWD
SET PREVWD=WARD
SET (PSGP,IEN)=$PIECE(PER,";",2)
SET PSJJORD=+ORD
if ORD["V"
DO IVREC
if $DATA(QFLG)
QUIT
if ORD'["V"
DO UDREC
if $DATA(QFLG)
QUIT
End DoDot:1
+8 ;
DONE KILL ADCNT,CONT,FST,JJ,LCNT,LN,ND3,ND3FLG,ND4,ON,OPI,ORD,P,PER,PG,PREVNM,PEVWD,PRIMD,PSJAD,PSJSOL,RSTFLG,SI,SND,SOLCNT,SSN,TMPNM,TMPWD,WCNT,WFLG,WRD,WARD,RMBD,PSJ,DRGI,DRGN,DRGT
+1 QUIT
+2 ;
UDREC ;write Unit Dose record
+1 NEW X,PSJ
KILL ND3FLG
+2 DO DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",30,30,.PSJ,0)
+3 SET RSTFLG=2
SET SSN=$PIECE(ND,U)
SET WARD=$PIECE(ND,U,2)
SET RMBD=$PIECE(ND,U,3)
+4 if $Y+5>IOSL
DO HEADING
if $DATA(QFLG)
QUIT
+5 WRITE !!,NM,?32,PSJ(1),?68,$EXTRACT($$ENDTC^PSGMI(STD),1,5),?75,$EXTRACT($$ENDTC^PSGMI($PIECE(ND,U,6)),1,5),!
if 'WFLG
WRITE SSN
+6 NEW X
FOR X=1:0
SET X=$ORDER(PSJ(X))
if 'X
QUIT
WRITE ?32,PSJ(X)
DO THEREST
IF RSTFLG>3&($X>32)
WRITE !
+7 NEW I
SET WCNT=1
SET SI=$PIECE($GET(^PS(55,PSGP,5,PSJJORD,6)),"^")
IF $TRANSLATE(SI," ")]""
if $X>31
WRITE !
FOR I=1:1:$LENGTH(SI," ")
SET WRD=$PIECE(SI," ",I)
if (I>1)&$PIECE(SI," ",I-1,180)=""
QUIT
SET WCNT=WCNT+1
Begin DoDot:1
+8 IF $X+$LENGTH(WRD)>79
WRITE !
IF 'WFLG&('$DATA(ND3FLG))
WRITE $PIECE(ND,"^",3)
SET ND3FLG=1
+9 WRITE ?31," ",WRD
End DoDot:1
+10 IF 'WFLG&('$DATA(ND3FLG))
WRITE !,$PIECE(ND,"^",3)
+11 KILL ND3FLG
+12 QUIT
IVREC ;write IV record
+1 if $Y+5>IOSL
DO HEADING
if $DATA(QFLG)
QUIT
+2 NEW DRG,P,PSG,ON55,PSJ
+3 SET RSTFLG=1
SET SSN=$PIECE(ND,U)
SET WARD=$PIECE(ND,U,2)
SET RMBD=$PIECE(ND,U,3)
+4 SET DFN=PSGP
SET ON=PSJJORD
DO GT55^PSIVORFB
+5 WRITE !!,NM
+6 NEW X
FOR X=0:0
SET X=$ORDER(DRG("AD",X))
if 'X
QUIT
DO NAME^PSIVUTL(DRG("AD",X),30,.PSJ,1)
FOR JJ=0:0
SET JJ=$ORDER(PSJ(JJ))
if 'JJ
QUIT
WRITE ?32,PSJ(JJ)
DO THEREST
IF RSTFLG>3&($X>32)
WRITE !
+7 NEW X,PSJ
FOR X=0:0
SET X=$ORDER(DRG("SOL",X))
if 'X
QUIT
DO NAME^PSIVUTL(DRG("SOL",X),30,.PSJ,0)
NEW JJ
FOR JJ=0:0
SET JJ=$ORDER(PSJ(JJ))
if 'JJ
QUIT
if JJ=1
WRITE ?33,"in "
WRITE ?36,PSJ(JJ)
DO THEREST
IF RSTFLG>3&($X>31)
WRITE !
+8 WRITE ?32,$PIECE(P("MR"),U,2)_" "_P(9)_" "_P(8)
DO THEREST
+9 SET OPI=$PIECE(P("OPI"),"^")
IF OPI]""
if $X>31
WRITE !
FOR X=1:1:$LENGTH(OPI," ")
SET Y=$PIECE(OPI," ",X)
DO THEREST
if $X+$LENGTH(Y)>80
WRITE !
WRITE ?32,Y," "
+10 FOR
if RSTFLG>3
QUIT
DO THEREST
+11 QUIT
THEREST ;
+1 IF RSTFLG=1
WRITE ?68,$EXTRACT($$ENDTC^PSGMI(STD),1,5),?75,$EXTRACT($$ENDTC^PSGMI(P(3)),1,5),!
if 'WFLG
WRITE SSN
+2 IF RSTFLG=2
WRITE !
if 'WFLG
WRITE WARD
+3 IF RSTFLG=3
SET ND3FLG=1
WRITE !
if 'WFLG
WRITE RMBD
+4 SET RSTFLG=RSTFLG+1
+5 QUIT
HEADING IF $EXTRACT(IOST)'="P"
WRITE !,"Press RETURN to continue ""^"" to exit: "
READ CONT:DTIME
if CONT["^"
SET QFLG=1
if $DATA(QFLG)
QUIT
+1 if $Y
WRITE @IOF
+2 SET NM=TMPNM
SET WFLG=0
+3 WRITE !,$EXTRACT($$ENDTC^PSGMI(DT),1,8),?70,"PAGE: ",PG
SET PG=PG+1
+4 SET LN="LISTING OF PATIENTS WITH ORDERS CONTAINING "_$SELECT(PSJSL="V":"VA CLASS(ES) OF DRUGS",PSJSL="O":"ORDERABLE ITEM(S)",PSJSL="D":"DISPENSE DRUG(S)")_":"
+5 WRITE !!
DO LINE
WRITE !
+6 SET LN=""
FOR
SET LN=$ORDER(PSJSNM(LN))
if LN=""
QUIT
WRITE !
DO LINE
+7 SET LN="FROM "_$$ENDTC^PSGMI(PSJREPS)_" TO "_$$ENDTC^PSGMI(PSJREPF)
WRITE !!
DO LINE
WRITE !!
+8 FOR X=1:1:80
WRITE "-"
+9 WRITE !?68,"Start",?75,"Stop",!,"Patient",?32,"Order",?68,"Date",?75,"Date",!
+10 FOR X=1:1:80
WRITE "-"
+11 QUIT
LINE ;
+1 WRITE ?(80-$LENGTH(LN))/2,LN
QUIT
