PSOBAIRP ;BIR/RTR-Report of prescription mail labels with bad address ;08/16/2006
;;7.0;OUTPATIENT PHARMACY;**233,326**;DEC 1997;Build 11
;
EN ;
N PSOFORM,PSOAPAT,PSOSDT,PSOEDT,PSOSDTX,PSOEDTX,X,Y,X1,X2
W !!,"This option provides a report that shows patients and prescriptions whose last"
W !,"label activity had a routing of mail and no valid permanent or temporary"
W !,"address. It will also indicate whether the patient now has a good address.",!!
K DIR S DIR(0)="SB^S:Single;A:All",DIR("A")="Print report for a Single patient, or All patients",DIR("B")="Single",DIR("?")=" ",DIR("?",1)="Enter 'S' to print address changes for one patient over the selected"
S DIR("?",2)="date range, enter 'A' to print address changes for all patients",DIR("?",3)="over the selected date range."
D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) D MESS Q
S PSOFORM=$S(Y="S":1,1:0)
I 'PSOFORM G DATE
K DIC W ! S DIC(0)="QEAM",DIC("A")="Select PATIENT: " D EN^PSOPATLK S Y=PSOPTLK K DIC,PSOPTLK I Y<1!($D(DUOUT))!($D(DTOUT)) D MESS Q
S PSOAPAT=+Y
DATE ;
W !!
W ! K %DT S %DT="AEX",%DT("A")="Start fill date: " D ^%DT K %DT I Y<0!($D(DTOUT))!($D(DUOUT)) D MESS Q
S (%DT(0),PSOSDT)=Y D DD^%DT S PSOSDTX=Y
W ! S %DT="AEX",%DT("A")="End fill date: " D ^%DT K %DT I Y<0!($D(DTOUT))!($D(DUOUT)) D MESS Q
S PSOEDT=Y D DD^%DT S PSOEDTX=Y
S X1=PSOSDT,X2=-1 D C^%DTC S PSOSDT=X_".9999"
S X1=PSOEDT,X2=+1 D C^%DTC S PSOEDT=X
K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I $G(POP) D MESS Q
I $D(IO("Q")) D Q
.S ZTRTN="REP^PSOBAIRP",ZTDESC="Pharmacy bad address mail label report",ZTSAVE("PSOFORM")="",ZTSAVE("PSOAPAT")="",ZTSAVE("PSOSDT")="",ZTSAVE("PSOEDT")="",ZTSAVE("PSOEDTX")="",ZTSAVE("PSOSDTX")="" D ^%ZTLOAD K %ZIS
.W !!,"Report queued to print.",!
REP ;
K ^TMP("PSOBADL",$J)
N PSODEV,PSOUT,PSOLINE,PSOPAGE,PSOADND,PSOADF,PSOADFF,PSOAOPT,PSOAOPTA,PSOAOPTZ,PSOAOPTB,PSOAOPTC,PSOADLP,PSOANODE,PSOADX,PSORX,PSOADATE,PSOC,PSOAALL,PSOADFN,PSOANAME,PSONI,PSONX,PSONB,PSOASN,VA,DFN,PSONSSN,PSOAFLAG
U IO
S (PSOUT,PSOAFLAG)=0,PSODEV=$S($E(IOST,1,2)'="C-":0,1:1),PSOPAGE=1
S $P(PSOLINE,"-",78)=""
ALL ;Print report for all patients
N PSORD,PSORX,PSOLBL,PSOX
S PSORD=PSOSDT F S PSORD=$O(^PSRX("AD",PSORD)) Q:'PSORD!(PSORD>PSOEDT) D
.S PSORX=0 F S PSORX=$O(^PSRX("AD",PSORD,PSORX)) Q:'PSORX D
..S PSOLBL=$O(^PSRX(PSORX,"L",999999),-1) I 'PSOLBL Q
..S PSOX=$G(^PSRX(PSORX,"L",PSOLBL,0)) I PSOX["(BAD ADDRESS",PSOX'["WINDOW" D
...S PSOADFN=$P($G(^PSRX(PSORX,0)),"^",2) Q:'PSOADFN
...I $G(PSOFORM),PSOADFN'=PSOAPAT Q
...S PSOANAME=$P($G(^DPT(PSOADFN,0)),"^") Q:PSOANAME=""
...S ^TMP("PSOBADL",$J,PSOANAME,PSOADFN,PSORD,PSORX)=""
D HD
I '$D(^TMP("PSOBADL",$J)) W !!,"No data found to print for this date range.",! G END
S PSONI="" F S PSONI=$O(^TMP("PSOBADL",$J,PSONI)) Q:PSONI=""!(PSOUT) D
.S PSONX="" F S PSONX=$O(^TMP("PSOBADL",$J,PSONI,PSONX)) Q:PSONX=""!(PSOUT) D NAME,PRALL D
..S PSONB="" F S PSONB=$O(^TMP("PSOBADL",$J,PSONI,PSONX,PSONB)) Q:PSONB=""!(PSOUT) D
...S PSORX="" F S PSORX=$O(^TMP("PSOBADL",$J,PSONI,PSONX,PSONB,PSORX)) Q:PSORX=""!(PSOUT) D
....I ($Y+5)>IOSL D HD Q:PSOUT
....S Y=PSONB D DD^%DT S PSOADATE=Y
....D PRONE
END ;
K ^TMP("PSOBADL",$J)
K DTOUT,DUOUT
I '$G(PSOUT),PSODEV W !!,"End of Report." K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
I 'PSODEV W !!,"End of Report."
I PSODEV W !
E W @IOF
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
HD ;
I '$G(PSOFORM) S PSOAFLAG=1
I PSODEV,PSOPAGE'=1 W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S PSOUT=1 Q
I PSOPAGE=1,'PSODEV W ! I 1
E W @IOF
D W ?67,"PAGE: "_PSOPAGE S PSOPAGE=PSOPAGE+1
.I PSOFORM W !,"Bad address mail label report for "_$G(PSOANAME) Q
.W !,"Bad address mail label report for ALL Patients"
W !,"for fill date between "_$G(PSOSDTX)_" and "_$G(PSOEDTX)
W !,PSOLINE
Q
MESS ;
W !!,"Nothing queued to print.",!
Q
NAME ;Set name(ssn)
K VA S DFN=PSONX D PID^VADPT6
S PSONSSN=$G(PSONI)_" ("_$E(VA("PID"),5,12)_")"
K VA
Q
PRALL ;Print data for all patients
N PSOADDR
S PSOADDR=""
S PSOAFLAG=0
W !!,$G(PSONSSN) D CHKADDR W ?30," ",PSOADDR I ($Y+5)>IOSL D HD Q:PSOUT
Q
PRONE ;Print data for one patient
N PSORX0
S PSORX0=$G(^PSRX(PSORX,0)) I PSORX0=""!($P(PSORX0,"^",6)="") Q
D CON W !,$G(PSOADATE),?15," Rx#: ",$P(PSORX0,"^"),?30," ",$P($G(^PSDRUG($P(PSORX0,"^",6),0)),"^")
I ($Y+5)>IOSL D HD Q:PSOUT
Q
CON ;
I PSOAFLAG,'PSOFORM W !,$G(PSONSSN) S PSOAFLAG=0
Q
;
CHKADDR ;
N PSOBADR,PSOTEMP
I $G(PSONX)="" Q
S PSOBADR=$$BADADR^DGUTL3(PSONX)
I PSOBADR D
.S PSOTEMP=$$CHKTEMP^PSOBAI(PSONX)
I PSOBADR,'PSOTEMP S PSOADDR="** BAD ADDRESS **" Q
S PSOADDR="PATIENT NOW HAS A VALID ADDRESS"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOBAIRP 4790 printed Apr 09, 2024@21:34:42 Page 2
PSOBAIRP ;BIR/RTR-Report of prescription mail labels with bad address ;08/16/2006
+1 ;;7.0;OUTPATIENT PHARMACY;**233,326**;DEC 1997;Build 11
+2 ;
EN ;
+1 NEW PSOFORM,PSOAPAT,PSOSDT,PSOEDT,PSOSDTX,PSOEDTX,X,Y,X1,X2
+2 WRITE !!,"This option provides a report that shows patients and prescriptions whose last"
+3 WRITE !,"label activity had a routing of mail and no valid permanent or temporary"
+4 WRITE !,"address. It will also indicate whether the patient now has a good address.",!!
+5 KILL DIR
SET DIR(0)="SB^S:Single;A:All"
SET DIR("A")="Print report for a Single patient, or All patients"
SET DIR("B")="Single"
SET DIR("?")=" "
SET DIR("?",1)="Enter 'S' to print address changes for one patient over the selected"
+6 SET DIR("?",2)="date range, enter 'A' to print address changes for all patients"
SET DIR("?",3)="over the selected date range."
+7 DO ^DIR
KILL DIR
IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
DO MESS
QUIT
+8 SET PSOFORM=$SELECT(Y="S":1,1:0)
+9 IF 'PSOFORM
GOTO DATE
+10 KILL DIC
WRITE !
SET DIC(0)="QEAM"
SET DIC("A")="Select PATIENT: "
DO EN^PSOPATLK
SET Y=PSOPTLK
KILL DIC,PSOPTLK
IF Y<1!($DATA(DUOUT))!($DATA(DTOUT))
DO MESS
QUIT
+11 SET PSOAPAT=+Y
DATE ;
+1 WRITE !!
+2 WRITE !
KILL %DT
SET %DT="AEX"
SET %DT("A")="Start fill date: "
DO ^%DT
KILL %DT
IF Y<0!($DATA(DTOUT))!($DATA(DUOUT))
DO MESS
QUIT
+3 SET (%DT(0),PSOSDT)=Y
DO DD^%DT
SET PSOSDTX=Y
+4 WRITE !
SET %DT="AEX"
SET %DT("A")="End fill date: "
DO ^%DT
KILL %DT
IF Y<0!($DATA(DTOUT))!($DATA(DUOUT))
DO MESS
QUIT
+5 SET PSOEDT=Y
DO DD^%DT
SET PSOEDTX=Y
+6 SET X1=PSOSDT
SET X2=-1
DO C^%DTC
SET PSOSDT=X_".9999"
+7 SET X1=PSOEDT
SET X2=+1
DO C^%DTC
SET PSOEDT=X
+8 KILL IOP,%ZIS,POP
SET %ZIS="QM"
DO ^%ZIS
IF $GET(POP)
DO MESS
QUIT
+9 IF $DATA(IO("Q"))
Begin DoDot:1
+10 SET ZTRTN="REP^PSOBAIRP"
SET ZTDESC="Pharmacy bad address mail label report"
SET ZTSAVE("PSOFORM")=""
SET ZTSAVE("PSOAPAT")=""
SET ZTSAVE("PSOSDT")=""
SET ZTSAVE("PSOEDT")=""
SET ZTSAVE("PSOEDTX")=""
SET ZTSAVE("PSOSDTX")=""
DO ^%ZTLOAD
KILL %ZIS
+11 WRITE !!,"Report queued to print.",!
End DoDot:1
QUIT
REP ;
+1 KILL ^TMP("PSOBADL",$JOB)
+2 NEW PSODEV,PSOUT,PSOLINE,PSOPAGE,PSOADND,PSOADF,PSOADFF,PSOAOPT,PSOAOPTA,PSOAOPTZ,PSOAOPTB,PSOAOPTC,PSOADLP,PSOANODE,PSOADX,PSORX,PSOADATE,PSOC,PSOAALL,PSOADFN,PSOANAME,PSONI,PSONX,PSONB,PSOASN,VA,DFN,PSONSSN,PSOAFLAG
+3 USE IO
+4 SET (PSOUT,PSOAFLAG)=0
SET PSODEV=$SELECT($EXTRACT(IOST,1,2)'="C-":0,1:1)
SET PSOPAGE=1
+5 SET $PIECE(PSOLINE,"-",78)=""
ALL ;Print report for all patients
+1 NEW PSORD,PSORX,PSOLBL,PSOX
+2 SET PSORD=PSOSDT
FOR
SET PSORD=$ORDER(^PSRX("AD",PSORD))
if 'PSORD!(PSORD>PSOEDT)
QUIT
Begin DoDot:1
+3 SET PSORX=0
FOR
SET PSORX=$ORDER(^PSRX("AD",PSORD,PSORX))
if 'PSORX
QUIT
Begin DoDot:2
+4 SET PSOLBL=$ORDER(^PSRX(PSORX,"L",999999),-1)
IF 'PSOLBL
QUIT
+5 SET PSOX=$GET(^PSRX(PSORX,"L",PSOLBL,0))
IF PSOX["(BAD ADDRESS"
IF PSOX'["WINDOW"
Begin DoDot:3
+6 SET PSOADFN=$PIECE($GET(^PSRX(PSORX,0)),"^",2)
if 'PSOADFN
QUIT
+7 IF $GET(PSOFORM)
IF PSOADFN'=PSOAPAT
QUIT
+8 SET PSOANAME=$PIECE($GET(^DPT(PSOADFN,0)),"^")
if PSOANAME=""
QUIT
+9 SET ^TMP("PSOBADL",$JOB,PSOANAME,PSOADFN,PSORD,PSORX)=""
End DoDot:3
End DoDot:2
End DoDot:1
+10 DO HD
+11 IF '$DATA(^TMP("PSOBADL",$JOB))
WRITE !!,"No data found to print for this date range.",!
GOTO END
+12 SET PSONI=""
FOR
SET PSONI=$ORDER(^TMP("PSOBADL",$JOB,PSONI))
if PSONI=""!(PSOUT)
QUIT
Begin DoDot:1
+13 SET PSONX=""
FOR
SET PSONX=$ORDER(^TMP("PSOBADL",$JOB,PSONI,PSONX))
if PSONX=""!(PSOUT)
QUIT
DO NAME
DO PRALL
Begin DoDot:2
+14 SET PSONB=""
FOR
SET PSONB=$ORDER(^TMP("PSOBADL",$JOB,PSONI,PSONX,PSONB))
if PSONB=""!(PSOUT)
QUIT
Begin DoDot:3
+15 SET PSORX=""
FOR
SET PSORX=$ORDER(^TMP("PSOBADL",$JOB,PSONI,PSONX,PSONB,PSORX))
if PSORX=""!(PSOUT)
QUIT
Begin DoDot:4
+16 IF ($Y+5)>IOSL
DO HD
if PSOUT
QUIT
+17 SET Y=PSONB
DO DD^%DT
SET PSOADATE=Y
+18 DO PRONE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
END ;
+1 KILL ^TMP("PSOBADL",$JOB)
+2 KILL DTOUT,DUOUT
+3 IF '$GET(PSOUT)
IF PSODEV
WRITE !!,"End of Report."
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+4 IF 'PSODEV
WRITE !!,"End of Report."
+5 IF PSODEV
WRITE !
+6 IF '$TEST
WRITE @IOF
+7 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+8 QUIT
HD ;
+1 IF '$GET(PSOFORM)
SET PSOAFLAG=1
+2 IF PSODEV
IF PSOPAGE'=1
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue, '^' to exit"
DO ^DIR
KILL DIR
IF 'Y
SET PSOUT=1
QUIT
+3 IF PSOPAGE=1
IF 'PSODEV
WRITE !
IF 1
+4 IF '$TEST
WRITE @IOF
+5 Begin DoDot:1
+6 IF PSOFORM
WRITE !,"Bad address mail label report for "_$GET(PSOANAME)
QUIT
+7 WRITE !,"Bad address mail label report for ALL Patients"
End DoDot:1
WRITE ?67,"PAGE: "_PSOPAGE
SET PSOPAGE=PSOPAGE+1
+8 WRITE !,"for fill date between "_$GET(PSOSDTX)_" and "_$GET(PSOEDTX)
+9 WRITE !,PSOLINE
+10 QUIT
MESS ;
+1 WRITE !!,"Nothing queued to print.",!
+2 QUIT
NAME ;Set name(ssn)
+1 KILL VA
SET DFN=PSONX
DO PID^VADPT6
+2 SET PSONSSN=$GET(PSONI)_" ("_$EXTRACT(VA("PID"),5,12)_")"
+3 KILL VA
+4 QUIT
PRALL ;Print data for all patients
+1 NEW PSOADDR
+2 SET PSOADDR=""
+3 SET PSOAFLAG=0
+4 WRITE !!,$GET(PSONSSN)
DO CHKADDR
WRITE ?30," ",PSOADDR
IF ($Y+5)>IOSL
DO HD
if PSOUT
QUIT
+5 QUIT
PRONE ;Print data for one patient
+1 NEW PSORX0
+2 SET PSORX0=$GET(^PSRX(PSORX,0))
IF PSORX0=""!($PIECE(PSORX0,"^",6)="")
QUIT
+3 DO CON
WRITE !,$GET(PSOADATE),?15," Rx#: ",$PIECE(PSORX0,"^"),?30," ",$PIECE($GET(^PSDRUG($PIECE(PSORX0,"^",6),0)),"^")
+4 IF ($Y+5)>IOSL
DO HD
if PSOUT
QUIT
+5 QUIT
CON ;
+1 IF PSOAFLAG
IF 'PSOFORM
WRITE !,$GET(PSONSSN)
SET PSOAFLAG=0
+2 QUIT
+3 ;
CHKADDR ;
+1 NEW PSOBADR,PSOTEMP
+2 IF $GET(PSONX)=""
QUIT
+3 SET PSOBADR=$$BADADR^DGUTL3(PSONX)
+4 IF PSOBADR
Begin DoDot:1
+5 SET PSOTEMP=$$CHKTEMP^PSOBAI(PSONX)
End DoDot:1
+6 IF PSOBADR
IF 'PSOTEMP
SET PSOADDR="** BAD ADDRESS **"
QUIT
+7 SET PSOADDR="PATIENT NOW HAS A VALID ADDRESS"
+8 QUIT
