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 Oct 16, 2024@18:30:09 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
