- 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
- 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
