PSOBAIR2 ;BIR/RTR-Report of suspended prescriptions with bad address ;08/16/2006
;;7.0;OUTPATIENT PHARMACY;**233,200,264,362,753**;DEC 1997;Build 53
;External reference ^PS(55 supported by DBIA 2228
EN ;
N PSOAPAT,PSOSDT,PSOEDT,PSOSDTX,PSOEDTX,X,Y,X1,X2,PSUSDIV,PII,PSOCNT,PSOBDF
W !!,"This option shows unprinted suspended prescriptions for the following:",!
W !,"- BAD ADDRESS INDICATOR set in the PATIENT file (#2) and no active temporary",!," address"
W !,"- DO NOT MAIL set in the PHARMACY PATIENT file (#55)"
W !,"- FOREIGN ADDRESS set in the PATIENT file (#2) and no active US temporary",!," address",!
K DIR S DIR(0)="S^B:Bad Address Indicator;D:Do Not Mail;F:Foreign;A:All;",DIR("B")="A"
S DIR("A")="Print for Bad Address Indicator/Do Not Mail/Foreign/All (B/D/F/A)"
S DIR("?")="Print prescriptions with Bad Address Indicated/Do Not Mail/Foreign Address, or all"
D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) D MESS Q
S PSOBDF=Y
DATE ;
W ! S %DT="AEX",%DT("A")="Ending suspense 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=PSOEDT,X2=+1 D C^%DTC S PSOEDT=X
D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) D MESS Q
S PSOCNT=0 F PII=0:0 S PII=$O(^PS(59,PII)) Q:'PII S PSOCNT=PSOCNT+1
I PSOCNT=1 G SKIP
W !!?3,"You are logged in under the "_$P($G(^PS(59,+$G(PSOSITE),0)),"^")_" division.",!
K DIR S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Print only those Rx's suspended for this division",DIR("?")="Enter 'Yes' to print only those Rx's for this division, enter 'No' to print Rx's suspended for all divisions."
D ^DIR K DIR I Y["^"!($D(DIRUT)) D MESS Q
S PSUSDIV=Y
SKIP ;
K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I $G(POP) D MESS Q
I $D(IO("Q")) D Q
.N GG
.S ZTRTN="REP^PSOBAIR2",ZTDESC="Pharmacy bad address suspense report" D
..F GG="PSOSITE","PSOAPAT","PSOSDT","PSOEDT","PSOEDTX","PSOSDTX","PSUSDIV" S:$D(@GG) ZTSAVE(GG)=""
..S ZTSAVE("PSOBDF*")="" D ^%ZTLOAD K %ZIS
.W !!,"Report queued to print.",!
REP ;
K ^TMP("PSOBADL",$J) S (PSOBDF("B"),PSOBDF("D"),PSOBDF("F"))=0
N PSODEV,PSOUT,PSOLINE,PSOPAGE,PSOADND,PSOADF,PSOADFF,PSOAOPT,PSOAOPTA,PSOAOPTZ,PSOAOPTB,PSOAOPTC,PSOADLP,PSOANODE,PSOADX,SFN,PSOADATE,PSOC,PSOAALL,PSODFN,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 ;
N PSORD,SFN,PSOLBL,PSOX,PSODFN,RXIEN,PRINTED,RXSITE,RXSTS,PARTIAL
S PSODFN=0 F S PSODFN=$O(^PS(52.5,"AC",PSODFN)) Q:'PSODFN D
.;p753 moved down
.;S (PSOBAI,PSOBDF("B"),PSOBDF("D"),PSOBDF("F"))=0 D CHKADDR,FOREIGN,CHKMAIL Q:(PSOBDF("B")+PSOBDF("D")+PSOBDF("F"))=0
.;Q:(PSOBDF="A"&'(PSOBDF("B")!PSOBDF("F")!PSOBDF("D"))) I PSOBDF'="A" Q:('PSOBDF(PSOBDF))
.S PSORD=0 F S PSORD=$O(^PS(52.5,"AC",PSODFN,PSORD)) Q:'PSORD!(PSORD>PSOEDT) D
..S SFN=0 F S SFN=$O(^PS(52.5,"AC",PSODFN,PSORD,SFN)) Q:'SFN D
...S (PSOBAI,PSOBDF("B"),PSOBDF("D"),PSOBDF("F"))=0 D CHKADDR,FOREIGN,CHKMAIL Q:(PSOBDF("B")+PSOBDF("D")+PSOBDF("F"))=0
...Q:(PSOBDF="A"&'(PSOBDF("B")!PSOBDF("F")!PSOBDF("D"))) I PSOBDF'="A" Q:('PSOBDF(PSOBDF))
...D DETAIL
S PSODFN=0 F S PSODFN=$O(^PS(52.5,"AG",PSODFN)) Q:'PSODFN D
.;p753 moved down
.;S (PSOBAI,PSOBDF("B"),PSOBDF("D"),PSOBDF("F"))=0 D CHKADDR,FOREIGN,CHKMAIL Q:(PSOBDF("B")+PSOBDF("D")+PSOBDF("F"))=0
.;Q:(PSOBDF="A"&'(PSOBDF("B")!PSOBDF("F")!PSOBDF("D"))) I PSOBDF'="A" Q:('PSOBDF(PSOBDF))
.S SFN=0 F S SFN=$O(^PS(52.5,"AG",PSODFN,SFN)) Q:'SFN D
..S PSORD=$G(^PS(52.5,SFN,0)),PSORD=$P(PSORD,"^",2) I PSORD<PSOEDT D
...S (PSOBAI,PSOBDF("B"),PSOBDF("D"),PSOBDF("F"))=0 D CHKADDR,FOREIGN,CHKMAIL Q:(PSOBDF("B")+PSOBDF("D")+PSOBDF("F"))=0
...Q:(PSOBDF="A"&'(PSOBDF("B")!PSOBDF("F")!PSOBDF("D"))) I PSOBDF'="A" Q:('PSOBDF(PSOBDF))
...D DETAIL
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 SFN="" F S SFN=$O(^TMP("PSOBADL",$J,PSONI,PSONX,PSONB,SFN)) Q:SFN=""!(PSOUT) D
....I ($Y+5)>IOSL D HD Q:PSOUT
....S Y=PSONB D DD^%DT S PSOADATE=Y
....S PNODE=$G(^TMP("PSOBADL",$J,PSONI,PSONX,PSONB,SFN)) D PRONE
END ;
I PSOBDF="A" W !!!,"NOTE: B=BAD ADDRESS INDICATOR D=NO NOT MAIL F=FOREIGN ADDRESS"
K ^TMP("PSOBADL",$J)
K DTOUT,DUOUT,PSOBAI
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 ;
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
.W !,"Suspense "_$S(PSOBDF="A":"BAI/DO NOT MAIL/FOREIGN ADRESS",PSOBDF="B":"BAD ADDRESS INDICATOR",PSOBDF="D":"DO NOT MAIL",1:"FOREIGN ADDRESS")_" report - division = ",$S($G(PSUSDIV):$P($G(^PS(59,+$G(PSOSITE),0)),"^"),1:"ALL")
W !,"for suspense dates through "_$G(PSOEDTX) W:PSOBDF="A" ?70,"B/D/F"
W !,PSOLINE
Q
MESS ;
W !!,"Nothing queued to print.",!
K DTOUT,DUOUT
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 SFN0
S SFN0=$G(^PSRX(SFN,0)) I SFN0=""!($P(SFN0,"^",6)="") Q
D CON W !,$G(PSOADATE),?15," Rx#: ",$P(SFN0,"^"),?30," ",$P($G(^PSDRUG($P(SFN0,"^",6),0)),"^")
W:PSOBDF="A" ?70,PNODE
I ($Y+5)>IOSL D HD Q:PSOUT
Q
CON ;
I PSOAFLAG W !,$G(PSONSSN) S PSOAFLAG=0
Q
;
CHKADDR ;
N PSOBADR,PSOTEMP
S PSOBADR=$$BADADR^DGUTL3(PSODFN)
I PSOBADR D
.S PSOTEMP=$$CHKTEMP^PSOBAI(PSODFN)
I PSOBADR,'PSOTEMP S (PSOBAI,PSOBDF("B"))=1 Q
Q
;
FOREIGN ;
N PSOFORGN,PSON
S DFN=PSODFN D ADD^VADPT
S PSOFORGN=$P($G(VAPA(25)),"^",2) I PSOFORGN'="" D ;*362
.S PSOBDF("F")=1
.S PSON=$$GET1^DIQ(59,PSOSITE,.01)
.I PSON'["MANILA",PSOFORGN["UNITED STATES" S PSOBDF("F")=0 Q
.I PSON["MANILA",PSOFORGN["PHILIPPINES" S PSOBDF("F")=0
Q
;
CHKMAIL ;
N PSOTEMP,MAIL,MAILEXP,PSRX
S PSOTEMP=$G(^PS(55,$G(PSODFN),0))
S MAIL=$P(PSOTEMP,"^",3)
S MAILEXP=$P(PSOTEMP,"^",5)
I '$D(^PS(52.5,$G(SFN),0)) Q
;p753
S PSRX=+$$GET1^DIQ(52.5,$G(SFN),.01,"I")
I $$GET1^DIQ(52,PSRX,100.2,"I")]"" S MAIL=$$GET1^DIQ(52,PSRX,100.2,"I"),MAILEXP=""
Q:MAIL'=2
I MAILEXP=""!(MAILEXP>DT) S PSOBDF("D")=1
Q
;
DETAIL ;
I '$D(^PS(52.5,SFN,0))!'$D(^DPT(+PSODFN,0)) Q
S RXIEN=+$$GET1^DIQ(52.5,SFN,.01,"I")
S RXSITE=+$$GET1^DIQ(52.5,SFN,.06,"I")
I $G(PSUSDIV),RXSITE'=$G(PSOSITE) Q
S RXSTS=$$GET1^DIQ(52,RXIEN,100,"I") I RXSTS>8 Q
S PARTIAL=+$$GET1^DIQ(52.5,SFN,.05,"I")
I PARTIAL,'$D(^PSRX(RXIEN,"P",PARTIAL)) Q
S PSOANAME=$P($G(^DPT(PSODFN,0)),"^") Q:PSOANAME=""
S ^TMP("PSOBADL",$J,PSOANAME,PSODFN,PSORD,RXIEN)=$S(PSOBDF("B"):"B",PSOBDF("D"):"D",PSOBDF("F"):"F",1:"")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOBAIR2 7259 printed Nov 22, 2024@17:34:40 Page 2
PSOBAIR2 ;BIR/RTR-Report of suspended prescriptions with bad address ;08/16/2006
+1 ;;7.0;OUTPATIENT PHARMACY;**233,200,264,362,753**;DEC 1997;Build 53
+2 ;External reference ^PS(55 supported by DBIA 2228
EN ;
+1 NEW PSOAPAT,PSOSDT,PSOEDT,PSOSDTX,PSOEDTX,X,Y,X1,X2,PSUSDIV,PII,PSOCNT,PSOBDF
+2 WRITE !!,"This option shows unprinted suspended prescriptions for the following:",!
+3 WRITE !,"- BAD ADDRESS INDICATOR set in the PATIENT file (#2) and no active temporary",!," address"
+4 WRITE !,"- DO NOT MAIL set in the PHARMACY PATIENT file (#55)"
+5 WRITE !,"- FOREIGN ADDRESS set in the PATIENT file (#2) and no active US temporary",!," address",!
+6 KILL DIR
SET DIR(0)="S^B:Bad Address Indicator;D:Do Not Mail;F:Foreign;A:All;"
SET DIR("B")="A"
+7 SET DIR("A")="Print for Bad Address Indicator/Do Not Mail/Foreign/All (B/D/F/A)"
+8 SET DIR("?")="Print prescriptions with Bad Address Indicated/Do Not Mail/Foreign Address, or all"
+9 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
DO MESS
QUIT
+10 SET PSOBDF=Y
DATE ;
+1 WRITE !
SET %DT="AEX"
SET %DT("A")="Ending suspense date: "
DO ^%DT
KILL %DT
IF Y<0!($DATA(DTOUT))!($DATA(DUOUT))
DO MESS
QUIT
+2 SET PSOEDT=Y
DO DD^%DT
SET PSOEDTX=Y
+3 SET X1=PSOEDT
SET X2=+1
DO C^%DTC
SET PSOEDT=X
+4 if '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
DO MESS
QUIT
+5 SET PSOCNT=0
FOR PII=0:0
SET PII=$ORDER(^PS(59,PII))
if 'PII
QUIT
SET PSOCNT=PSOCNT+1
+6 IF PSOCNT=1
GOTO SKIP
+7 WRITE !!?3,"You are logged in under the "_$PIECE($GET(^PS(59,+$GET(PSOSITE),0)),"^")_" division.",!
+8 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="Yes"
SET DIR("A")="Print only those Rx's suspended for this division"
SET DIR("?")="Enter 'Yes' to print only those Rx's for this division, enter 'No' to print Rx's suspended for all divisions."
+9 DO ^DIR
KILL DIR
IF Y["^"!($DATA(DIRUT))
DO MESS
QUIT
+10 SET PSUSDIV=Y
SKIP ;
+1 KILL IOP,%ZIS,POP
SET %ZIS="QM"
DO ^%ZIS
IF $GET(POP)
DO MESS
QUIT
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 NEW GG
+4 SET ZTRTN="REP^PSOBAIR2"
SET ZTDESC="Pharmacy bad address suspense report"
Begin DoDot:2
+5 FOR GG="PSOSITE","PSOAPAT","PSOSDT","PSOEDT","PSOEDTX","PSOSDTX","PSUSDIV"
if $DATA(@GG)
SET ZTSAVE(GG)=""
+6 SET ZTSAVE("PSOBDF*")=""
DO ^%ZTLOAD
KILL %ZIS
End DoDot:2
+7 WRITE !!,"Report queued to print.",!
End DoDot:1
QUIT
REP ;
+1 KILL ^TMP("PSOBADL",$JOB)
SET (PSOBDF("B"),PSOBDF("D"),PSOBDF("F"))=0
+2 NEW PSODEV,PSOUT,PSOLINE,PSOPAGE,PSOADND,PSOADF,PSOADFF,PSOAOPT,PSOAOPTA,PSOAOPTZ,PSOAOPTB,PSOAOPTC,PSOADLP,PSOANODE,PSOADX,SFN,PSOADATE,PSOC,PSOAALL,PSODFN,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 ;
+1 NEW PSORD,SFN,PSOLBL,PSOX,PSODFN,RXIEN,PRINTED,RXSITE,RXSTS,PARTIAL
+2 SET PSODFN=0
FOR
SET PSODFN=$ORDER(^PS(52.5,"AC",PSODFN))
if 'PSODFN
QUIT
Begin DoDot:1
+3 ;p753 moved down
+4 ;S (PSOBAI,PSOBDF("B"),PSOBDF("D"),PSOBDF("F"))=0 D CHKADDR,FOREIGN,CHKMAIL Q:(PSOBDF("B")+PSOBDF("D")+PSOBDF("F"))=0
+5 ;Q:(PSOBDF="A"&'(PSOBDF("B")!PSOBDF("F")!PSOBDF("D"))) I PSOBDF'="A" Q:('PSOBDF(PSOBDF))
+6 SET PSORD=0
FOR
SET PSORD=$ORDER(^PS(52.5,"AC",PSODFN,PSORD))
if 'PSORD!(PSORD>PSOEDT)
QUIT
Begin DoDot:2
+7 SET SFN=0
FOR
SET SFN=$ORDER(^PS(52.5,"AC",PSODFN,PSORD,SFN))
if 'SFN
QUIT
Begin DoDot:3
+8 SET (PSOBAI,PSOBDF("B"),PSOBDF("D"),PSOBDF("F"))=0
DO CHKADDR
DO FOREIGN
DO CHKMAIL
if (PSOBDF("B")+PSOBDF("D")+PSOBDF("F"))=0
QUIT
+9 if (PSOBDF="A"&'(PSOBDF("B")!PSOBDF("F")!PSOBDF("D")))
QUIT
IF PSOBDF'="A"
if ('PSOBDF(PSOBDF))
QUIT
+10 DO DETAIL
End DoDot:3
End DoDot:2
End DoDot:1
+11 SET PSODFN=0
FOR
SET PSODFN=$ORDER(^PS(52.5,"AG",PSODFN))
if 'PSODFN
QUIT
Begin DoDot:1
+12 ;p753 moved down
+13 ;S (PSOBAI,PSOBDF("B"),PSOBDF("D"),PSOBDF("F"))=0 D CHKADDR,FOREIGN,CHKMAIL Q:(PSOBDF("B")+PSOBDF("D")+PSOBDF("F"))=0
+14 ;Q:(PSOBDF="A"&'(PSOBDF("B")!PSOBDF("F")!PSOBDF("D"))) I PSOBDF'="A" Q:('PSOBDF(PSOBDF))
+15 SET SFN=0
FOR
SET SFN=$ORDER(^PS(52.5,"AG",PSODFN,SFN))
if 'SFN
QUIT
Begin DoDot:2
+16 SET PSORD=$GET(^PS(52.5,SFN,0))
SET PSORD=$PIECE(PSORD,"^",2)
IF PSORD<PSOEDT
Begin DoDot:3
+17 SET (PSOBAI,PSOBDF("B"),PSOBDF("D"),PSOBDF("F"))=0
DO CHKADDR
DO FOREIGN
DO CHKMAIL
if (PSOBDF("B")+PSOBDF("D")+PSOBDF("F"))=0
QUIT
+18 if (PSOBDF="A"&'(PSOBDF("B")!PSOBDF("F")!PSOBDF("D")))
QUIT
IF PSOBDF'="A"
if ('PSOBDF(PSOBDF))
QUIT
+19 DO DETAIL
End DoDot:3
End DoDot:2
End DoDot:1
+20 DO HD
+21 IF '$DATA(^TMP("PSOBADL",$JOB))
WRITE !!,"No data found to print for this date range.",!
GOTO END
+22 SET PSONI=""
FOR
SET PSONI=$ORDER(^TMP("PSOBADL",$JOB,PSONI))
if PSONI=""!(PSOUT)
QUIT
Begin DoDot:1
+23 SET PSONX=""
FOR
SET PSONX=$ORDER(^TMP("PSOBADL",$JOB,PSONI,PSONX))
if PSONX=""!(PSOUT)
QUIT
DO NAME
DO PRALL
Begin DoDot:2
+24 SET PSONB=""
FOR
SET PSONB=$ORDER(^TMP("PSOBADL",$JOB,PSONI,PSONX,PSONB))
if PSONB=""!(PSOUT)
QUIT
Begin DoDot:3
+25 SET SFN=""
FOR
SET SFN=$ORDER(^TMP("PSOBADL",$JOB,PSONI,PSONX,PSONB,SFN))
if SFN=""!(PSOUT)
QUIT
Begin DoDot:4
+26 IF ($Y+5)>IOSL
DO HD
if PSOUT
QUIT
+27 SET Y=PSONB
DO DD^%DT
SET PSOADATE=Y
+28 SET PNODE=$GET(^TMP("PSOBADL",$JOB,PSONI,PSONX,PSONB,SFN))
DO PRONE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
END ;
+1 IF PSOBDF="A"
WRITE !!!,"NOTE: B=BAD ADDRESS INDICATOR D=NO NOT MAIL F=FOREIGN ADDRESS"
+2 KILL ^TMP("PSOBADL",$JOB)
+3 KILL DTOUT,DUOUT,PSOBAI
+4 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
+5 IF 'PSODEV
WRITE !!,"End of Report."
+6 IF PSODEV
WRITE !
+7 IF '$TEST
WRITE @IOF
+8 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+9 QUIT
HD ;
+1 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 WRITE !,"Suspense "_$SELECT(PSOBDF="A":"BAI/DO NOT MAIL/FOREIGN ADRESS",PSOBDF="B":"BAD ADDRESS INDICATOR",PSOBDF="D":"DO NOT MAIL",1:"FOREIGN ADDRESS")_" report - division = ",$SELECT($GET(PSUSDIV):$PIECE($GET(^PS(59,+$GET(PSOSITE),0)),"^"
),1:"ALL")
End DoDot:1
WRITE ?67,"PAGE: "_PSOPAGE
SET PSOPAGE=PSOPAGE+1
+7 WRITE !,"for suspense dates through "_$GET(PSOEDTX)
if PSOBDF="A"
WRITE ?70,"B/D/F"
+8 WRITE !,PSOLINE
+9 QUIT
MESS ;
+1 WRITE !!,"Nothing queued to print.",!
+2 KILL DTOUT,DUOUT
+3 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 SFN0
+2 SET SFN0=$GET(^PSRX(SFN,0))
IF SFN0=""!($PIECE(SFN0,"^",6)="")
QUIT
+3 DO CON
WRITE !,$GET(PSOADATE),?15," Rx#: ",$PIECE(SFN0,"^"),?30," ",$PIECE($GET(^PSDRUG($PIECE(SFN0,"^",6),0)),"^")
+4 if PSOBDF="A"
WRITE ?70,PNODE
+5 IF ($Y+5)>IOSL
DO HD
if PSOUT
QUIT
+6 QUIT
CON ;
+1 IF PSOAFLAG
WRITE !,$GET(PSONSSN)
SET PSOAFLAG=0
+2 QUIT
+3 ;
CHKADDR ;
+1 NEW PSOBADR,PSOTEMP
+2 SET PSOBADR=$$BADADR^DGUTL3(PSODFN)
+3 IF PSOBADR
Begin DoDot:1
+4 SET PSOTEMP=$$CHKTEMP^PSOBAI(PSODFN)
End DoDot:1
+5 IF PSOBADR
IF 'PSOTEMP
SET (PSOBAI,PSOBDF("B"))=1
QUIT
+6 QUIT
+7 ;
FOREIGN ;
+1 NEW PSOFORGN,PSON
+2 SET DFN=PSODFN
DO ADD^VADPT
+3 ;*362
SET PSOFORGN=$PIECE($GET(VAPA(25)),"^",2)
IF PSOFORGN'=""
Begin DoDot:1
+4 SET PSOBDF("F")=1
+5 SET PSON=$$GET1^DIQ(59,PSOSITE,.01)
+6 IF PSON'["MANILA"
IF PSOFORGN["UNITED STATES"
SET PSOBDF("F")=0
QUIT
+7 IF PSON["MANILA"
IF PSOFORGN["PHILIPPINES"
SET PSOBDF("F")=0
End DoDot:1
+8 QUIT
+9 ;
CHKMAIL ;
+1 NEW PSOTEMP,MAIL,MAILEXP,PSRX
+2 SET PSOTEMP=$GET(^PS(55,$GET(PSODFN),0))
+3 SET MAIL=$PIECE(PSOTEMP,"^",3)
+4 SET MAILEXP=$PIECE(PSOTEMP,"^",5)
+5 IF '$DATA(^PS(52.5,$GET(SFN),0))
QUIT
+6 ;p753
+7 SET PSRX=+$$GET1^DIQ(52.5,$GET(SFN),.01,"I")
+8 IF $$GET1^DIQ(52,PSRX,100.2,"I")]""
SET MAIL=$$GET1^DIQ(52,PSRX,100.2,"I")
SET MAILEXP=""
+9 if MAIL'=2
QUIT
+10 IF MAILEXP=""!(MAILEXP>DT)
SET PSOBDF("D")=1
+11 QUIT
+12 ;
DETAIL ;
+1 IF '$DATA(^PS(52.5,SFN,0))!'$DATA(^DPT(+PSODFN,0))
QUIT
+2 SET RXIEN=+$$GET1^DIQ(52.5,SFN,.01,"I")
+3 SET RXSITE=+$$GET1^DIQ(52.5,SFN,.06,"I")
+4 IF $GET(PSUSDIV)
IF RXSITE'=$GET(PSOSITE)
QUIT
+5 SET RXSTS=$$GET1^DIQ(52,RXIEN,100,"I")
IF RXSTS>8
QUIT
+6 SET PARTIAL=+$$GET1^DIQ(52.5,SFN,.05,"I")
+7 IF PARTIAL
IF '$DATA(^PSRX(RXIEN,"P",PARTIAL))
QUIT
+8 SET PSOANAME=$PIECE($GET(^DPT(PSODFN,0)),"^")
if PSOANAME=""
QUIT
+9 SET ^TMP("PSOBADL",$JOB,PSOANAME,PSODFN,PSORD,RXIEN)=$SELECT(PSOBDF("B"):"B",PSOBDF("D"):"D",PSOBDF("F"):"F",1:"")
+10 QUIT
