- 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 Feb 18, 2025@23:51:07 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
