- PSOFTDR ;BHAM/MHA - free text dosage entry report ; 06/14/01
- ;;7.0;OUTPATIENT PHARMACY;**80,90**;DEC 1997
- ;External Ref. ^PSDRUG( is supp. by DBIA# 221
- ;External reference to ^PS(50.607 supported by DBIA 2221
- BEG W !!,"This option provides a list of drugs for those prescriptions"
- W !,"where the dosage field has a free text entry.",!
- W ! S %DT(0)=-DT,%DT("A")="Beginning Date: ",%DT="APE" D ^%DT Q:Y<0!($D(DTOUT)) S (%DT(0),BEGDATE)=Y
- W ! S %DT("A")="Ending Date: " D ^%DT Q:Y<0!($D(DTOUT)) S ENDDATE=Y D:+$E(Y,6,7)=0 DTC
- DEV K %ZIS,IOP,POP,ZTSK S PSOION=ION,%ZIS="QM" D ^%ZIS K %ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION W !,"Please try later!" Q
- K PSOION I $D(IO("Q")) D Q
- .S ZTDESC="Rx free text dosage report",ZTRTN="START^PSOFTDR" F G="BEGDATE","ENDDATE" S:$D(@G) ZTSAVE(G)=""
- .K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!" K ZTSK
- START N PSOPG,PSODT,PSORXN,PSORF,PSODS,PSODR,PSODRN,PSORX0,PSOPR,PSOCNT,PSOJ,PSOL,PSOY,PSOC,TY,PSO2,PSOU
- S TY="PSOFT" K ^TMP(TY,$J)
- S PSODT=BEGDATE-.01,Q=0 W:$E(IOST)="C" !!!,"Hmm.. working hard - please wait.."
- ST1 F S PSODT=$O(^PSRX("AD",PSODT)) Q:'PSODT!(PSODT>(ENDDATE_".999999")) D Q:$D(DIRUT)
- .S PSORXN=0 F S PSORXN=$O(^PSRX("AD",PSODT,PSORXN)) Q:'PSORXN D Q:$D(DIRUT)
- ..S PSORF="" F S PSORF=$O(^PSRX("AD",PSODT,PSORXN,PSORF)) Q:PSORF="" D:'PSORF Q:$D(DIRUT)
- ...Q:'$D(^PSRX(PSORXN,0)) S PSORX0=^(0),PSODR=+$P(PSORX0,"^",6)
- ...Q:'$D(^PSDRUG(PSODR,0))
- ...I $E(IOST)="C" S Q=Q+1 W:'(Q#50) "."
- ...I $O(^PSRX(PSORXN,6,0)) S PSOJ=0 F S PSOJ=$O(^PSRX(PSORXN,6,PSOJ)) Q:'PSOJ I $P(^(PSOJ,0),"^")]"" S PSODS=$P(^(0),"^"),PSO2=$P(^(0),"^",2),PSOU=$P(^(0),"^",3) D:PSO2 FT1 D:'PSO2 FT2
- U IO S PSOPG=1,PSOCNT=0 D HD
- I '$D(^TMP(TY,$J,"B")) W !!,"***** No Records were found for this period *****",!! G EXIT
- DET S J="" F S J=$O(^TMP(TY,$J,"B",J)) Q:J="" D Q:$D(DIRUT)
- .S L="",Q=0 F S L=$O(^TMP(TY,$J,"B",J,L)) Q:L="" D Q:$D(DIRUT)
- ..S PSODR=$O(^TMP(TY,$J,"B",J,L,0))
- ..W:'Q !,$E(J,1,30)_" ("_PSODR_")"
- ..W:$L(L)>35 ?40,$E(L,1,35),!,?40,$E(L,36,99) W:$L(L)'>35 ?40,L
- ..W ?75,+^TMP(TY,$J,"B",J,L,PSODR,0),!," " S Q=Q+1
- ..S M=0 F S M=$O(^TMP(TY,$J,"B",J,L,PSODR,M)) Q:'M!($D(DIRUT)) S YY=^TMP(TY,$J,"B",J,L,PSODR,M) D
- ...F I=1:1:$L(YY,";") S XX=$P(YY,";",I) D Q:$D(DIRUT)
- ....S T=$P(^VA(200,+XX,0),"^")_":"_$P(XX,",",2)_" " W:($X+$L(T))>78 !," "
- ....W T D HD:($Y+5)>IOSL Q:$D(DIRUT)
- ...Q:$D(DIRUT) D HD:($Y+5)>IOSL
- ..Q:$D(DIRUT)
- ..W ! D HD:($Y+5)>IOSL
- EXIT W ! D ^%ZISC K DIR,DTOUT,DUOUT,DIROUT,DIRUT,^TMP(TY,$J),I,J,K,L,M,Q,T,X,XX,Y,YY,BEGDATE,ENDDATE
- S:$D(ZTQUEUED) ZTREQ="@"
- Q
- FT1 ;check for possible dosages. If does not match report
- S PSOC=1,PSOL=0 F S PSOL=$O(^PSDRUG(PSODR,"DOS1",PSOL)) Q:'PSOL S:$P(^(PSOL,0),"^",2)=PSODS PSOC=0
- I PSOC S PSODS=PSODS_$S(PSOU:$P($G(^PS(50.607,PSOU,0)),"^"),1:"") D PRD
- Q
- FT2 ;check for local possible dosages. If does not exist report
- I '$D(^PSDRUG(PSODR,"DOS2")) D PRD Q
- S PSOC=1,PSOL=0 F S PSOL=$O(^PSDRUG(PSODR,"DOS2",PSOL)) Q:'PSOL S:$P(^(PSOL,0),"^")=PSODS PSOC=0
- D:PSOC PRD
- Q
- PRD ;
- S PSODRN=$P(^PSDRUG(PSODR,0),"^"),PSOPR=+$P(PSORX0,"^",4)
- Q:'PSOPR
- I $D(^TMP(TY,$J,"B",PSODRN,PSODS,PSODR,0)) D
- .S ^TMP(TY,$J,"B",PSODRN,PSODS,PSODR,0)=^TMP(TY,$J,"B",PSODRN,PSODS,PSODR,0)+1
- E S ^TMP(TY,$J,"B",PSODRN,PSODS,PSODR,0)=1
- I $O(^TMP(TY,$J,"B",PSODRN,PSODS,PSODR,0)) D GETR
- E S ^TMP(TY,$J,"B",PSODRN,PSODS,PSODR,1)=PSOPR_",1"
- Q
- GETR ;
- S (J,K)=0
- F S K=$O(^TMP(TY,$J,"B",PSODRN,PSODS,PSODR,K)) Q:'K!(J) D
- .S Y=^TMP(TY,$J,"B",PSODRN,PSODS,PSODR,K)
- .F I=1:1 S X=$P(Y,";",I) Q:'X!(J) D
- ..I PSOPR=+X S J=$P(X,",",2)+1,$P(^TMP(TY,$J,"B",PSODRN,PSODS,PSODR,K),";",I)=PSOPR_","_J Q
- .Q:J
- .I $L(Y)+$L(";"_(PSOPR_",1"))<246 S ^TMP(TY,$J,"B",PSODRN,PSODS,PSODR,K)=Y_";"_(PSOPR_",1")
- .E S ^TMP(TY,$J,"B",PSODRN,PSODS,PSODR,K+1)=PSOPR_",1",J=1
- Q
- HD ;
- I PSOPG>1,$E(IOST)="C" S DIR(0)="E",DIR("A")=" Press Return to Continue or ^ to Exit" D ^DIR K DIR
- Q:$D(DIRUT)
- I PSOPG=1,$E(IOST)="C" W @IOF
- W:PSOPG>1 @IOF W "Run Date: " S Y=DT D DT^DIO2 W ?72,"Page "_PSOPG S PSOPG=PSOPG+1
- W !,?20,"Free Text Dosage Entry Report",!,?15,"for the Period: "
- S Y=BEGDATE D DT^DIO2 W " to " S Y=ENDDATE D DT^DIO2
- 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 ENDDATE=Y+DD
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOFTDR 4487 printed Apr 23, 2025@18:43:58 Page 2
- PSOFTDR ;BHAM/MHA - free text dosage entry report ; 06/14/01
- +1 ;;7.0;OUTPATIENT PHARMACY;**80,90**;DEC 1997
- +2 ;External Ref. ^PSDRUG( is supp. by DBIA# 221
- +3 ;External reference to ^PS(50.607 supported by DBIA 2221
- BEG WRITE !!,"This option provides a list of drugs for those prescriptions"
- +1 WRITE !,"where the dosage field has a free text entry.",!
- +2 WRITE !
- SET %DT(0)=-DT
- SET %DT("A")="Beginning Date: "
- SET %DT="APE"
- DO ^%DT
- if Y<0!($DATA(DTOUT))
- QUIT
- SET (%DT(0),BEGDATE)=Y
- +3 WRITE !
- SET %DT("A")="Ending Date: "
- DO ^%DT
- if Y<0!($DATA(DTOUT))
- QUIT
- SET ENDDATE=Y
- if +$EXTRACT(Y,6,7)=0
- DO DTC
- DEV KILL %ZIS,IOP,POP,ZTSK
- SET PSOION=ION
- SET %ZIS="QM"
- DO ^%ZIS
- KILL %ZIS
- IF POP
- SET IOP=PSOION
- DO ^%ZIS
- KILL IOP,PSOION
- WRITE !,"Please try later!"
- QUIT
- +1 KILL PSOION
- IF $DATA(IO("Q"))
- Begin DoDot:1
- +2 SET ZTDESC="Rx free text dosage report"
- SET ZTRTN="START^PSOFTDR"
- FOR G="BEGDATE","ENDDATE"
- if $DATA(@G)
- SET ZTSAVE(G)=""
- +3 KILL IO("Q")
- DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !,"Report is Queued to print !!"
- KILL ZTSK
- End DoDot:1
- QUIT
- START NEW PSOPG,PSODT,PSORXN,PSORF,PSODS,PSODR,PSODRN,PSORX0,PSOPR,PSOCNT,PSOJ,PSOL,PSOY,PSOC,TY,PSO2,PSOU
- +1 SET TY="PSOFT"
- KILL ^TMP(TY,$JOB)
- +2 SET PSODT=BEGDATE-.01
- SET Q=0
- if $EXTRACT(IOST)="C"
- WRITE !!!,"Hmm.. working hard - please wait.."
- ST1 FOR
- SET PSODT=$ORDER(^PSRX("AD",PSODT))
- if 'PSODT!(PSODT>(ENDDATE_".999999"))
- QUIT
- Begin DoDot:1
- +1 SET PSORXN=0
- FOR
- SET PSORXN=$ORDER(^PSRX("AD",PSODT,PSORXN))
- if 'PSORXN
- QUIT
- Begin DoDot:2
- +2 SET PSORF=""
- FOR
- SET PSORF=$ORDER(^PSRX("AD",PSODT,PSORXN,PSORF))
- if PSORF=""
- QUIT
- if 'PSORF
- Begin DoDot:3
- +3 if '$DATA(^PSRX(PSORXN,0))
- QUIT
- SET PSORX0=^(0)
- SET PSODR=+$PIECE(PSORX0,"^",6)
- +4 if '$DATA(^PSDRUG(PSODR,0))
- QUIT
- +5 IF $EXTRACT(IOST)="C"
- SET Q=Q+1
- if '(Q#50)
- WRITE "."
- +6 IF $ORDER(^PSRX(PSORXN,6,0))
- SET PSOJ=0
- FOR
- SET PSOJ=$ORDER(^PSRX(PSORXN,6,PSOJ))
- if 'PSOJ
- QUIT
- IF $PIECE(^(PSOJ,0),"^")]""
- SET PSODS=$PIECE(^(0),"^")
- SET PSO2=$PIECE(^(0),"^",2)
- SET PSOU=$PIECE(^(0),"^",3)
- if PSO2
- DO FT1
- if 'PSO2
- DO FT2
- End DoDot:3
- if $DATA(DIRUT)
- QUIT
- End DoDot:2
- if $DATA(DIRUT)
- QUIT
- End DoDot:1
- if $DATA(DIRUT)
- QUIT
- +7 USE IO
- SET PSOPG=1
- SET PSOCNT=0
- DO HD
- +8 IF '$DATA(^TMP(TY,$JOB,"B"))
- WRITE !!,"***** No Records were found for this period *****",!!
- GOTO EXIT
- DET SET J=""
- FOR
- SET J=$ORDER(^TMP(TY,$JOB,"B",J))
- if J=""
- QUIT
- Begin DoDot:1
- +1 SET L=""
- SET Q=0
- FOR
- SET L=$ORDER(^TMP(TY,$JOB,"B",J,L))
- if L=""
- QUIT
- Begin DoDot:2
- +2 SET PSODR=$ORDER(^TMP(TY,$JOB,"B",J,L,0))
- +3 if 'Q
- WRITE !,$EXTRACT(J,1,30)_" ("_PSODR_")"
- +4 if $LENGTH(L)>35
- WRITE ?40,$EXTRACT(L,1,35),!,?40,$EXTRACT(L,36,99)
- if $LENGTH(L)'>35
- WRITE ?40,L
- +5 WRITE ?75,+^TMP(TY,$JOB,"B",J,L,PSODR,0),!," "
- SET Q=Q+1
- +6 SET M=0
- FOR
- SET M=$ORDER(^TMP(TY,$JOB,"B",J,L,PSODR,M))
- if 'M!($DATA(DIRUT))
- QUIT
- SET YY=^TMP(TY,$JOB,"B",J,L,PSODR,M)
- Begin DoDot:3
- +7 FOR I=1:1:$LENGTH(YY,";")
- SET XX=$PIECE(YY,";",I)
- Begin DoDot:4
- +8 SET T=$PIECE(^VA(200,+XX,0),"^")_":"_$PIECE(XX,",",2)_" "
- if ($X+$LENGTH(T))>78
- WRITE !," "
- +9 WRITE T
- if ($Y+5)>IOSL
- DO HD
- if $DATA(DIRUT)
- QUIT
- End DoDot:4
- if $DATA(DIRUT)
- QUIT
- +10 if $DATA(DIRUT)
- QUIT
- if ($Y+5)>IOSL
- DO HD
- End DoDot:3
- +11 if $DATA(DIRUT)
- QUIT
- +12 WRITE !
- if ($Y+5)>IOSL
- DO HD
- 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(TY,$JOB),I,J,K,L,M,Q,T,X,XX,Y,YY,BEGDATE,ENDDATE
- +1 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 QUIT
- FT1 ;check for possible dosages. If does not match report
- +1 SET PSOC=1
- SET PSOL=0
- FOR
- SET PSOL=$ORDER(^PSDRUG(PSODR,"DOS1",PSOL))
- if 'PSOL
- QUIT
- if $PIECE(^(PSOL,0),"^",2)=PSODS
- SET PSOC=0
- +2 IF PSOC
- SET PSODS=PSODS_$SELECT(PSOU:$PIECE($GET(^PS(50.607,PSOU,0)),"^"),1:"")
- DO PRD
- +3 QUIT
- FT2 ;check for local possible dosages. If does not exist report
- +1 IF '$DATA(^PSDRUG(PSODR,"DOS2"))
- DO PRD
- QUIT
- +2 SET PSOC=1
- SET PSOL=0
- FOR
- SET PSOL=$ORDER(^PSDRUG(PSODR,"DOS2",PSOL))
- if 'PSOL
- QUIT
- if $PIECE(^(PSOL,0),"^")=PSODS
- SET PSOC=0
- +3 if PSOC
- DO PRD
- +4 QUIT
- PRD ;
- +1 SET PSODRN=$PIECE(^PSDRUG(PSODR,0),"^")
- SET PSOPR=+$PIECE(PSORX0,"^",4)
- +2 if 'PSOPR
- QUIT
- +3 IF $DATA(^TMP(TY,$JOB,"B",PSODRN,PSODS,PSODR,0))
- Begin DoDot:1
- +4 SET ^TMP(TY,$JOB,"B",PSODRN,PSODS,PSODR,0)=^TMP(TY,$JOB,"B",PSODRN,PSODS,PSODR,0)+1
- End DoDot:1
- +5 IF '$TEST
- SET ^TMP(TY,$JOB,"B",PSODRN,PSODS,PSODR,0)=1
- +6 IF $ORDER(^TMP(TY,$JOB,"B",PSODRN,PSODS,PSODR,0))
- DO GETR
- +7 IF '$TEST
- SET ^TMP(TY,$JOB,"B",PSODRN,PSODS,PSODR,1)=PSOPR_",1"
- +8 QUIT
- GETR ;
- +1 SET (J,K)=0
- +2 FOR
- SET K=$ORDER(^TMP(TY,$JOB,"B",PSODRN,PSODS,PSODR,K))
- if 'K!(J)
- QUIT
- Begin DoDot:1
- +3 SET Y=^TMP(TY,$JOB,"B",PSODRN,PSODS,PSODR,K)
- +4 FOR I=1:1
- SET X=$PIECE(Y,";",I)
- if 'X!(J)
- QUIT
- Begin DoDot:2
- +5 IF PSOPR=+X
- SET J=$PIECE(X,",",2)+1
- SET $PIECE(^TMP(TY,$JOB,"B",PSODRN,PSODS,PSODR,K),";",I)=PSOPR_","_J
- QUIT
- End DoDot:2
- +6 if J
- QUIT
- +7 IF $LENGTH(Y)+$LENGTH(";"_(PSOPR_",1"))<246
- SET ^TMP(TY,$JOB,"B",PSODRN,PSODS,PSODR,K)=Y_";"_(PSOPR_",1")
- +8 IF '$TEST
- SET ^TMP(TY,$JOB,"B",PSODRN,PSODS,PSODR,K+1)=PSOPR_",1"
- SET J=1
- End DoDot:1
- +9 QUIT
- HD ;
- +1 IF PSOPG>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 IF PSOPG=1
- IF $EXTRACT(IOST)="C"
- WRITE @IOF
- +4 if PSOPG>1
- WRITE @IOF
- WRITE "Run Date: "
- SET Y=DT
- DO DT^DIO2
- WRITE ?72,"Page "_PSOPG
- SET PSOPG=PSOPG+1
- +5 WRITE !,?20,"Free Text Dosage Entry Report",!,?15,"for the Period: "
- +6 SET Y=BEGDATE
- DO DT^DIO2
- WRITE " to "
- SET Y=ENDDATE
- DO DT^DIO2
- +7 WRITE !,"Drug",?40,"Free Text Entry",?74,"Count",!," Provider:Count"
- +8 WRITE !
- FOR Y=1:1:79
- WRITE "-"
- +9 WRITE !
- QUIT
- DTC 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
- +1 SET ENDDATE=Y+DD
- +2 QUIT
