- 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 Feb 18, 2025@23:35:17 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