PSJFTR ;BIR/JCH-INPATIENT MEDS FREE TEXT DOSAGE REPORT ;15 Nov 01 / 9:45 AM
;;5.0; INPATIENT MEDICATIONS ;**65,73,76,111**;16 Dec 97
;
; Reference to ^PSDRUG is supported by DBIA 2192.
; Reference to ^PS(55 is supported by DBIA 2191.
; Reference to ^PSSORPH is supported by DBIA 3234.
;
;List IP orders that have free text dosages for a given date range.
;Report is sorted by drug and physician.
;
BEG ;Begin
N BEGDT,ENDT
W !,"This report searches for Free Text Dosages in Inpatient Unit Dose Orders"
W !,"for a range of dates. Orders with Stop Dates that fall within the range"
W !,"are included in the report."
W ! K %DT S %DT("A")="Beginning Date: ",%DT="APE"
D ^%DT G:Y<0!($D(DTOUT)) EXIT S (%DT(0),BEGDT)=Y
W ! S %DT("A")="Ending Date: "
D ^%DT G:Y<0!($D(DTOUT)) EXIT S ENDT=Y D:+$E(Y,6,7)=0 DTC
K %DT(0)
;
DEV ;Device
K %ZIS,IOP,POP,ZTSK S PSJION=$I,%ZIS="QM"
D ^%ZIS K %ZIS
I POP S IOP=PSJION D ^%ZIS K IOP,PSJION W !,"Please try later!" G EXIT
K PSJION I $D(IO("Q")) D G EXIT
.S ZTDESC="Rx free text dosage report",ZTRTN="START^PSJFTR"
.F G="BEGDT","ENDT" S:$D(@G) ZTSAVE(G)=""
.K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print!" K ZTSK
START ;Start processing date range
N PSGND0,PSGDT,PSGORD,PSJDOSE,PSGDRG,PSJDRN,PSJPR,PSJCNT
N PSJL,PSJY,PSJC,STOPDT,DRGNODE,STDT
K ^TMP("PSJFTR",$J)
S Q=0 W:$E(IOST)="C" !!!,"Working - please wait.."
UD ;
ST1 ;
S PSGDFN=0,STOPDT=ENDT_".99999"
F S PSGDFN=$O(^PS(55,PSGDFN)) Q:'PSGDFN!$D(DIRUT) D
.S STDT=BEGDT-.0001
.F S STDT=$O(^PS(55,PSGDFN,5,"AUS",STDT)) Q:'STDT!(STDT>STOPDT)!$D(DIRUT) D
..S PSGORD="" I PSGDFN=740 S JCH=$G(JCH)+1
..F S PSGORD=$O(^PS(55,PSGDFN,5,"AUS",STDT,PSGORD)) Q:PSGORD=""!$D(DIRUT) D
...Q:'$D(^PS(55,PSGDFN,5,PSGORD,1,0))
...S PSGDCNT=0 F S PSGDCNT=$O(^PS(55,PSGDFN,5,PSGORD,1,PSGDCNT)) Q:'PSGDCNT D
....N PKG,LOCNOD,ORDOSE,FMDOSE,FMUNIT,NOTXT,NXT,DARRAY,POSDOSE,LOCDOSE
....S NOTXT=0
....S PSGDRG=+$G(^PS(55,PSGDFN,5,PSGORD,1,PSGDCNT,0))
....Q:'$D(^PSDRUG(PSGDRG))!'PSGDRG
....S DRGNODE=$G(^PS(55,PSGDFN,5,PSGORD,.2)),PSGND0=^PS(55,PSGDFN,5,PSGORD,0)
....S FMDOSE=$P(DRGNODE,"^",5),FMUNIT=$P(DRGNODE,"^",6)
....I FMDOSE]"",FMUNIT]"" Q
....S ORDOSE=$P(DRGNODE,"^",2) Q:ORDOSE="" ; Nothing there?
....I $E(IOST)="C" S Q=Q+1 W:'(Q#50) "."
....K DARRAY S DARRAY="" D DOSE^PSSORPH(.DARRAY,PSGDRG,"U")
....I '$G(DARRAY(1)) D CHKLOC ; check local doses
....I $G(DARRAY(1)) D CHKPOS ; check possible doses
....Q:NOTXT ; Not free text
....D PRD
U IO S PSJPG=1,PSJCNT=0 D HD
I '$D(^TMP("PSJFTR",$J,"B")) W !!,"***** No Records were found for this period *****",!! G EXIT
DET ;
S J="" F S J=$O(^TMP("PSJFTR",$J,"B",J)) Q:J="" D Q:$D(DIRUT)
.S L="",Q=0,Q2=0
.F S L=$O(^TMP("PSJFTR",$J,"B",J,L)) Q:L="" D Q:$D(DIRUT)
..S PSGDRG=$O(^TMP("PSJFTR",$J,"B",J,L,0))
..Q:'PSGDRG
..S Y=^TMP("PSJFTR",$J,"B",J,L,PSGDRG,0)
..W:'Q !,$E(J,1,30)_" ("_PSGDRG_")"
..W:Q2'=Q !,$E(J,1,30)_" ("_PSGDRG_")"," - (Continued)",!
..W:$L(L)>35 ?40,$E(L,1,35),!,?40,$E(L,36,99) W:$L(L)'>35 ?40,L
..W ?75,+Y,!," "
..S Q=Q+1,Q2=Q
..S PR=0 F S PR=$O(^TMP("PSJFTR",$J,"B",J,L,PSGDRG,PR)) Q:'PR D
...S Y=^TMP("PSJFTR",$J,"B",J,L,PSGDRG,PR),T=$S(PR=.1:"PROVIDER NOT FOUND",1:$P(^VA(200,+PR,0),"^"))
...S T=T_":"_Y_" "
...W:($X+$L(T))>74 !?4
...W T
..W ! I ($Y+5)>IOSL D HD S Q2=0
EXIT W ! D ^%ZISC K DIR,DTOUT,DUOUT,DIROUT,DIRUT,^TMP("PSJFTR",$J),I,X,T,J,L,Q,Y
S:$D(ZTQUEUED) ZTREQ="@"
Q
PRD ;
S PSJDRN=$P(^PSDRUG(PSGDRG,0),"^"),PSJPR=+$P(PSGND0,"^",2)
I 'PSJPR S PSJPR=.1
I '$D(^TMP("PSJFTR",$J,"B",PSJDRN,ORDOSE,PSGDRG,PSJPR)) D Q
.S ^TMP("PSJFTR",$J,"B",PSJDRN,ORDOSE,PSGDRG,PSJPR)=1
.S ^TMP("PSJFTR",$J,"B",PSJDRN,ORDOSE,PSGDRG,0)=$G(^TMP("PSJFTR",$J,"B",PSJDRN,ORDOSE,PSGDRG,0))+1
I $D(^TMP("PSJFTR",$J,"B",PSJDRN,ORDOSE,PSGDRG,PSJPR)) D Q
.S Y=^TMP("PSJFTR",$J,"B",PSJDRN,ORDOSE,PSGDRG,PSJPR)
.S Y=Y+1,^TMP("PSJFTR",$J,"B",PSJDRN,ORDOSE,PSGDRG,PSJPR)=Y
.S X=^TMP("PSJFTR",$J,"B",PSJDRN,ORDOSE,PSGDRG,0)
.S X=X+1,^TMP("PSJFTR",$J,"B",PSJDRN,ORDOSE,PSGDRG,0)=X
Q
;
CHKPOS ; Check for possible doses
S NOTXT=0
S NXT="" F S NXT=$O(DARRAY(NXT)) Q:'NXT!NOTXT D
.Q:$P($G(^PSDRUG(PSGDRG,"DOS1",NXT,0)),"^",3)'["I"
.S POSDOSE=$P(DARRAY(NXT),"^",1)_$P(DARRAY(NXT),"^",2) I POSDOSE=ORDOSE S NOTXT=1
Q
;
CHKLOC ; Check for local doses
S NOTXT=0
S NXT="" F S NXT=$O(DARRAY(NXT)) Q:'NXT!NOTXT D
.Q:$P($G(^PSDRUG(PSGDRG,"DOS2",NXT,0)),"^",2)'["I"
.S LOCDOSE=$P(DARRAY(NXT),"^",3) I LOCDOSE=ORDOSE S NOTXT=1
Q
;
HD ;
I PSJPG>1,$E(IOST)="C" S DIR(0)="E",DIR("A")=" Press Return to Continue or ^ to Exit" D ^DIR K DIR
Q:$D(DIRUT)
N FMTDT
I PSJPG=1,$E(IOST)="C" W @IOF
I PSJPG>1 W @IOF W "Run Date: " S FMTDT=$$FMTE^XLFDT(DT) W FMTDT
W ?72,"Page "_PSJPG S PSJPG=PSJPG+1
W !,?15,"Inpatient Free Text Dosage Entry Report",!,?17,"Period: "
S FMTDT=$$FMTE^XLFDT(BEGDT) W FMTDT W " to "
S FMTDT=$$FMTE^XLFDT(ENDT) W FMTDT
W !,"Drug",?40,"Free Text Entry",?74,"Count",!," Provider:Count"
W ! F Y=1:1:79 W "-"
W ! Q
DTC ;
N DD,MM S DD=31,MM=+$E(Y,4,5) I MM'=12 S MM=MM+1,MM=$S(MM<10:"0",1:"")_MM,X2=Y,X1=$E(Y,1,3)_MM_"00" D ^%DTC S DD=X
S ENDT=Y+DD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJFTR 5245 printed Sep 23, 2025@19:42:56 Page 2
PSJFTR ;BIR/JCH-INPATIENT MEDS FREE TEXT DOSAGE REPORT ;15 Nov 01 / 9:45 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**65,73,76,111**;16 Dec 97
+2 ;
+3 ; Reference to ^PSDRUG is supported by DBIA 2192.
+4 ; Reference to ^PS(55 is supported by DBIA 2191.
+5 ; Reference to ^PSSORPH is supported by DBIA 3234.
+6 ;
+7 ;List IP orders that have free text dosages for a given date range.
+8 ;Report is sorted by drug and physician.
+9 ;
BEG ;Begin
+1 NEW BEGDT,ENDT
+2 WRITE !,"This report searches for Free Text Dosages in Inpatient Unit Dose Orders"
+3 WRITE !,"for a range of dates. Orders with Stop Dates that fall within the range"
+4 WRITE !,"are included in the report."
+5 WRITE !
KILL %DT
SET %DT("A")="Beginning Date: "
SET %DT="APE"
+6 DO ^%DT
if Y<0!($DATA(DTOUT))
GOTO EXIT
SET (%DT(0),BEGDT)=Y
+7 WRITE !
SET %DT("A")="Ending Date: "
+8 DO ^%DT
if Y<0!($DATA(DTOUT))
GOTO EXIT
SET ENDT=Y
if +$EXTRACT(Y,6,7)=0
DO DTC
+9 KILL %DT(0)
+10 ;
DEV ;Device
+1 KILL %ZIS,IOP,POP,ZTSK
SET PSJION=$IO
SET %ZIS="QM"
+2 DO ^%ZIS
KILL %ZIS
+3 IF POP
SET IOP=PSJION
DO ^%ZIS
KILL IOP,PSJION
WRITE !,"Please try later!"
GOTO EXIT
+4 KILL PSJION
IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTDESC="Rx free text dosage report"
SET ZTRTN="START^PSJFTR"
+6 FOR G="BEGDT","ENDT"
if $DATA(@G)
SET ZTSAVE(G)=""
+7 KILL IO("Q")
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report is Queued to print!"
KILL ZTSK
End DoDot:1
GOTO EXIT
START ;Start processing date range
+1 NEW PSGND0,PSGDT,PSGORD,PSJDOSE,PSGDRG,PSJDRN,PSJPR,PSJCNT
+2 NEW PSJL,PSJY,PSJC,STOPDT,DRGNODE,STDT
+3 KILL ^TMP("PSJFTR",$JOB)
+4 SET Q=0
if $EXTRACT(IOST)="C"
WRITE !!!,"Working - please wait.."
UD ;
ST1 ;
+1 SET PSGDFN=0
SET STOPDT=ENDT_".99999"
+2 FOR
SET PSGDFN=$ORDER(^PS(55,PSGDFN))
if 'PSGDFN!$DATA(DIRUT)
QUIT
Begin DoDot:1
+3 SET STDT=BEGDT-.0001
+4 FOR
SET STDT=$ORDER(^PS(55,PSGDFN,5,"AUS",STDT))
if 'STDT!(STDT>STOPDT)!$DATA(DIRUT)
QUIT
Begin DoDot:2
+5 SET PSGORD=""
IF PSGDFN=740
SET JCH=$GET(JCH)+1
+6 FOR
SET PSGORD=$ORDER(^PS(55,PSGDFN,5,"AUS",STDT,PSGORD))
if PSGORD=""!$DATA(DIRUT)
QUIT
Begin DoDot:3
+7 if '$DATA(^PS(55,PSGDFN,5,PSGORD,1,0))
QUIT
+8 SET PSGDCNT=0
FOR
SET PSGDCNT=$ORDER(^PS(55,PSGDFN,5,PSGORD,1,PSGDCNT))
if 'PSGDCNT
QUIT
Begin DoDot:4
+9 NEW PKG,LOCNOD,ORDOSE,FMDOSE,FMUNIT,NOTXT,NXT,DARRAY,POSDOSE,LOCDOSE
+10 SET NOTXT=0
+11 SET PSGDRG=+$GET(^PS(55,PSGDFN,5,PSGORD,1,PSGDCNT,0))
+12 if '$DATA(^PSDRUG(PSGDRG))!'PSGDRG
QUIT
+13 SET DRGNODE=$GET(^PS(55,PSGDFN,5,PSGORD,.2))
SET PSGND0=^PS(55,PSGDFN,5,PSGORD,0)
+14 SET FMDOSE=$PIECE(DRGNODE,"^",5)
SET FMUNIT=$PIECE(DRGNODE,"^",6)
+15 IF FMDOSE]""
IF FMUNIT]""
QUIT
+16 ; Nothing there?
SET ORDOSE=$PIECE(DRGNODE,"^",2)
if ORDOSE=""
QUIT
+17 IF $EXTRACT(IOST)="C"
SET Q=Q+1
if '(Q#50)
WRITE "."
+18 KILL DARRAY
SET DARRAY=""
DO DOSE^PSSORPH(.DARRAY,PSGDRG,"U")
+19 ; check local doses
IF '$GET(DARRAY(1))
DO CHKLOC
+20 ; check possible doses
IF $GET(DARRAY(1))
DO CHKPOS
+21 ; Not free text
if NOTXT
QUIT
+22 DO PRD
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 USE IO
SET PSJPG=1
SET PSJCNT=0
DO HD
+24 IF '$DATA(^TMP("PSJFTR",$JOB,"B"))
WRITE !!,"***** No Records were found for this period *****",!!
GOTO EXIT
DET ;
+1 SET J=""
FOR
SET J=$ORDER(^TMP("PSJFTR",$JOB,"B",J))
if J=""
QUIT
Begin DoDot:1
+2 SET L=""
SET Q=0
SET Q2=0
+3 FOR
SET L=$ORDER(^TMP("PSJFTR",$JOB,"B",J,L))
if L=""
QUIT
Begin DoDot:2
+4 SET PSGDRG=$ORDER(^TMP("PSJFTR",$JOB,"B",J,L,0))
+5 if 'PSGDRG
QUIT
+6 SET Y=^TMP("PSJFTR",$JOB,"B",J,L,PSGDRG,0)
+7 if 'Q
WRITE !,$EXTRACT(J,1,30)_" ("_PSGDRG_")"
+8 if Q2'=Q
WRITE !,$EXTRACT(J,1,30)_" ("_PSGDRG_")"," - (Continued)",!
+9 if $LENGTH(L)>35
WRITE ?40,$EXTRACT(L,1,35),!,?40,$EXTRACT(L,36,99)
if $LENGTH(L)'>35
WRITE ?40,L
+10 WRITE ?75,+Y,!," "
+11 SET Q=Q+1
SET Q2=Q
+12 SET PR=0
FOR
SET PR=$ORDER(^TMP("PSJFTR",$JOB,"B",J,L,PSGDRG,PR))
if 'PR
QUIT
Begin DoDot:3
+13 SET Y=^TMP("PSJFTR",$JOB,"B",J,L,PSGDRG,PR)
SET T=$SELECT(PR=.1:"PROVIDER NOT FOUND",1:$PIECE(^VA(200,+PR,0),"^"))
+14 SET T=T_":"_Y_" "
+15 if ($X+$LENGTH(T))>74
WRITE !?4
+16 WRITE T
End DoDot:3
+17 WRITE !
IF ($Y+5)>IOSL
DO HD
SET Q2=0
End DoDot:2
if $DATA(DIRUT)
QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
EXIT WRITE !
DO ^%ZISC
KILL DIR,DTOUT,DUOUT,DIROUT,DIRUT,^TMP("PSJFTR",$JOB),I,X,T,J,L,Q,Y
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
PRD ;
+1 SET PSJDRN=$PIECE(^PSDRUG(PSGDRG,0),"^")
SET PSJPR=+$PIECE(PSGND0,"^",2)
+2 IF 'PSJPR
SET PSJPR=.1
+3 IF '$DATA(^TMP("PSJFTR",$JOB,"B",PSJDRN,ORDOSE,PSGDRG,PSJPR))
Begin DoDot:1
+4 SET ^TMP("PSJFTR",$JOB,"B",PSJDRN,ORDOSE,PSGDRG,PSJPR)=1
+5 SET ^TMP("PSJFTR",$JOB,"B",PSJDRN,ORDOSE,PSGDRG,0)=$GET(^TMP("PSJFTR",$JOB,"B",PSJDRN,ORDOSE,PSGDRG,0))+1
End DoDot:1
QUIT
+6 IF $DATA(^TMP("PSJFTR",$JOB,"B",PSJDRN,ORDOSE,PSGDRG,PSJPR))
Begin DoDot:1
+7 SET Y=^TMP("PSJFTR",$JOB,"B",PSJDRN,ORDOSE,PSGDRG,PSJPR)
+8 SET Y=Y+1
SET ^TMP("PSJFTR",$JOB,"B",PSJDRN,ORDOSE,PSGDRG,PSJPR)=Y
+9 SET X=^TMP("PSJFTR",$JOB,"B",PSJDRN,ORDOSE,PSGDRG,0)
+10 SET X=X+1
SET ^TMP("PSJFTR",$JOB,"B",PSJDRN,ORDOSE,PSGDRG,0)=X
End DoDot:1
QUIT
+11 QUIT
+12 ;
CHKPOS ; Check for possible doses
+1 SET NOTXT=0
+2 SET NXT=""
FOR
SET NXT=$ORDER(DARRAY(NXT))
if 'NXT!NOTXT
QUIT
Begin DoDot:1
+3 if $PIECE($GET(^PSDRUG(PSGDRG,"DOS1",NXT,0)),"^",3)'["I"
QUIT
+4 SET POSDOSE=$PIECE(DARRAY(NXT),"^",1)_$PIECE(DARRAY(NXT),"^",2)
IF POSDOSE=ORDOSE
SET NOTXT=1
End DoDot:1
+5 QUIT
+6 ;
CHKLOC ; Check for local doses
+1 SET NOTXT=0
+2 SET NXT=""
FOR
SET NXT=$ORDER(DARRAY(NXT))
if 'NXT!NOTXT
QUIT
Begin DoDot:1
+3 if $PIECE($GET(^PSDRUG(PSGDRG,"DOS2",NXT,0)),"^",2)'["I"
QUIT
+4 SET LOCDOSE=$PIECE(DARRAY(NXT),"^",3)
IF LOCDOSE=ORDOSE
SET NOTXT=1
End DoDot:1
+5 QUIT
+6 ;
HD ;
+1 IF PSJPG>1
IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
SET DIR("A")=" Press Return to Continue or ^ to Exit"
DO ^DIR
KILL DIR
+2 if $DATA(DIRUT)
QUIT
+3 NEW FMTDT
+4 IF PSJPG=1
IF $EXTRACT(IOST)="C"
WRITE @IOF
+5 IF PSJPG>1
WRITE @IOF
WRITE "Run Date: "
SET FMTDT=$$FMTE^XLFDT(DT)
WRITE FMTDT
+6 WRITE ?72,"Page "_PSJPG
SET PSJPG=PSJPG+1
+7 WRITE !,?15,"Inpatient Free Text Dosage Entry Report",!,?17,"Period: "
+8 SET FMTDT=$$FMTE^XLFDT(BEGDT)
WRITE FMTDT
WRITE " to "
+9 SET FMTDT=$$FMTE^XLFDT(ENDT)
WRITE FMTDT
+10 WRITE !,"Drug",?40,"Free Text Entry",?74,"Count",!," Provider:Count"
+11 WRITE !
FOR Y=1:1:79
WRITE "-"
+12 WRITE !
QUIT
DTC ;
+1 NEW DD,MM
SET DD=31
SET MM=+$EXTRACT(Y,4,5)
IF MM'=12
SET MM=MM+1
SET MM=$SELECT(MM<10:"0",1:"")_MM
SET X2=Y
SET X1=$EXTRACT(Y,1,3)_MM_"00"
DO ^%DTC
SET DD=X
+2 SET ENDT=Y+DD
+3 QUIT
