PSOBAI ;BIR/EJW - BAD ADDRESS PROCESSING ;02/02/2006
;;7.0;OUTPATIENT PHARMACY;**233,258,268,264**;DEC 1997;Build 19
;
;External reference EN^DGREGAED supported by DBIA 4198
;External reference UPDATE^DGADDUTL supported by DBIA 4886
;External reference ^DPT( supported by DBIA 5031
;
CHKADDR(PSODFN,WARN,UPDATE) ; CHECK ADDRESS BY PATIENT
;Input: PSODFN - PATIENT file (#2) IEN
; WARN - Display warning (optional)
; UPDATE - If bad address flagged, prompt to update patient address (optional)
;If calling from patient selection, if bad, even if there is an active temporary address, prompt to update the address
N PSOBADR,PSOTEMP
I PSODFN="" Q
S PSOBADR=$$BADADR^DGUTL3(PSODFN)
I PSOBADR D
.S PSOTEMP=$$CHKTEMP(PSODFN)
.I $G(WARN) D
..D WARN1
..I $G(UPDATE) D UPDATE Q
..D PAUSE
Q
;
CHKRX(PSORX) ;CHECK ADDRESS BY RX
;Input: PSORX - PRESCRIPTION file (#52) IEN
;Output: PSOBADR - Bad Address Indicator_"^"_temporary address or not
N PSOBADR,PSODFN,PSOTEMP
S PSOBADR=""
I PSORX="" Q 0
S PSODFN=$P($G(^PSRX(PSORX,0)),"^",2) I PSODFN="" Q 0
S PSOBADR=$$BADADR^DGUTL3(PSODFN)
I PSOBADR S PSOTEMP=$$CHKTEMP(PSODFN)
S PSOBADR=PSOBADR_"^"_$G(PSOTEMP)
Q PSOBADR
;
WARN1 ;
W !!,?8,"WARNING: The patient address is indicated as a bad"
W !,?17,"address (",$S(PSOBADR=1:"UNDELIVERABLE",PSOBADR=2:"HOMELESS",1:"OTHER"),")."
I $G(PSOTEMP) W !,?17,"* Temporary address is active *" Q
W !,?17,"Medication will not be mailed to"
W !,?17,"the patient until the address has been"
W !,?17,"corrected.",!
Q
CHKTEMP(PSODFN) ; see if active temporary address
;Input: PSODFN - PATIENT file (#2) IEN
N DFN,VAPA
S DFN=PSODFN,PSOTEMP=0
D 6^VADPT I +VAPA(9) S PSOTEMP=1
Q PSOTEMP
;
UPDATE ;
N PSOSEL,DA
I '$D(PSOPAR) D ^PSOLSET
I '$P($G(PSOPAR),"^",22),'$D(^XUSEC("PSO ADDRESS UPDATE",+$G(DUZ))) D PAUSE Q
K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")="Do you want to update the address/phone"
D ^DIR K DIR
I Y'=1 Q
L +^DPT(PSODFN):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T D MSG,PAUSE Q
K DIR S DIR(0)="SAO^P:PERMANENT;T:TEMPORARY;B:BOTH"
S DIR("A")=" Update (P)ermanent address, (T)emporary, or (B)oth: "
S DIR("B")="BOTH" D ^DIR
I $D(DIRUT) G ULK
S PSOSEL=Y
I PSOSEL="P"!(PSOSEL="B") D
.;D UPDATE^DGADDUTL(PSODFN,"PERM") - THIS CALL CLEARS BAI FLAG INAPPROPRIATELY SO USE FOLLOWING TO UPDATE PERMANENT ADDRESS/PHONE INSTEAD 5/29/06
.N PSOFLG
.S PSOFLG(1)=1 D EN^DGREGAED(PSODFN,.PSOFLG) W !
S DA=PSODFN,DIE="^DPT(",DR=".134" D ^DIE W !
I PSOSEL="P" D ULK Q
I PSOSEL="B"!(PSOSEL="T") D UPDATE^DGADDUTL(PSODFN,"TEMP"),ULK,PAUSE
Q
ULK ;
L -^DPT(PSODFN)
Q
;
PAUSE ;
W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
Q
;
MSG ;
S VALMSG="Patient Data is being edited by another user!"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOBAI 2856 printed Sep 23, 2025@20:00:54 Page 2
PSOBAI ;BIR/EJW - BAD ADDRESS PROCESSING ;02/02/2006
+1 ;;7.0;OUTPATIENT PHARMACY;**233,258,268,264**;DEC 1997;Build 19
+2 ;
+3 ;External reference EN^DGREGAED supported by DBIA 4198
+4 ;External reference UPDATE^DGADDUTL supported by DBIA 4886
+5 ;External reference ^DPT( supported by DBIA 5031
+6 ;
CHKADDR(PSODFN,WARN,UPDATE) ; CHECK ADDRESS BY PATIENT
+1 ;Input: PSODFN - PATIENT file (#2) IEN
+2 ; WARN - Display warning (optional)
+3 ; UPDATE - If bad address flagged, prompt to update patient address (optional)
+4 ;If calling from patient selection, if bad, even if there is an active temporary address, prompt to update the address
+5 NEW PSOBADR,PSOTEMP
+6 IF PSODFN=""
QUIT
+7 SET PSOBADR=$$BADADR^DGUTL3(PSODFN)
+8 IF PSOBADR
Begin DoDot:1
+9 SET PSOTEMP=$$CHKTEMP(PSODFN)
+10 IF $GET(WARN)
Begin DoDot:2
+11 DO WARN1
+12 IF $GET(UPDATE)
DO UPDATE
QUIT
+13 DO PAUSE
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
CHKRX(PSORX) ;CHECK ADDRESS BY RX
+1 ;Input: PSORX - PRESCRIPTION file (#52) IEN
+2 ;Output: PSOBADR - Bad Address Indicator_"^"_temporary address or not
+3 NEW PSOBADR,PSODFN,PSOTEMP
+4 SET PSOBADR=""
+5 IF PSORX=""
QUIT 0
+6 SET PSODFN=$PIECE($GET(^PSRX(PSORX,0)),"^",2)
IF PSODFN=""
QUIT 0
+7 SET PSOBADR=$$BADADR^DGUTL3(PSODFN)
+8 IF PSOBADR
SET PSOTEMP=$$CHKTEMP(PSODFN)
+9 SET PSOBADR=PSOBADR_"^"_$GET(PSOTEMP)
+10 QUIT PSOBADR
+11 ;
WARN1 ;
+1 WRITE !!,?8,"WARNING: The patient address is indicated as a bad"
+2 WRITE !,?17,"address (",$SELECT(PSOBADR=1:"UNDELIVERABLE",PSOBADR=2:"HOMELESS",1:"OTHER"),")."
+3 IF $GET(PSOTEMP)
WRITE !,?17,"* Temporary address is active *"
QUIT
+4 WRITE !,?17,"Medication will not be mailed to"
+5 WRITE !,?17,"the patient until the address has been"
+6 WRITE !,?17,"corrected.",!
+7 QUIT
CHKTEMP(PSODFN) ; see if active temporary address
+1 ;Input: PSODFN - PATIENT file (#2) IEN
+2 NEW DFN,VAPA
+3 SET DFN=PSODFN
SET PSOTEMP=0
+4 DO 6^VADPT
IF +VAPA(9)
SET PSOTEMP=1
+5 QUIT PSOTEMP
+6 ;
UPDATE ;
+1 NEW PSOSEL,DA
+2 IF '$DATA(PSOPAR)
DO ^PSOLSET
+3 IF '$PIECE($GET(PSOPAR),"^",22)
IF '$DATA(^XUSEC("PSO ADDRESS UPDATE",+$GET(DUZ)))
DO PAUSE
QUIT
+4 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="N"
SET DIR("A")="Do you want to update the address/phone"
+5 DO ^DIR
KILL DIR
+6 IF Y'=1
QUIT
+7 LOCK +^DPT(PSODFN):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
DO MSG
DO PAUSE
QUIT
+8 KILL DIR
SET DIR(0)="SAO^P:PERMANENT;T:TEMPORARY;B:BOTH"
+9 SET DIR("A")=" Update (P)ermanent address, (T)emporary, or (B)oth: "
+10 SET DIR("B")="BOTH"
DO ^DIR
+11 IF $DATA(DIRUT)
GOTO ULK
+12 SET PSOSEL=Y
+13 IF PSOSEL="P"!(PSOSEL="B")
Begin DoDot:1
+14 ;D UPDATE^DGADDUTL(PSODFN,"PERM") - THIS CALL CLEARS BAI FLAG INAPPROPRIATELY SO USE FOLLOWING TO UPDATE PERMANENT ADDRESS/PHONE INSTEAD 5/29/06
+15 NEW PSOFLG
+16 SET PSOFLG(1)=1
DO EN^DGREGAED(PSODFN,.PSOFLG)
WRITE !
End DoDot:1
+17 SET DA=PSODFN
SET DIE="^DPT("
SET DR=".134"
DO ^DIE
WRITE !
+18 IF PSOSEL="P"
DO ULK
QUIT
+19 IF PSOSEL="B"!(PSOSEL="T")
DO UPDATE^DGADDUTL(PSODFN,"TEMP")
DO ULK
DO PAUSE
+20 QUIT
ULK ;
+1 LOCK -^DPT(PSODFN)
+2 QUIT
+3 ;
PAUSE ;
+1 WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+2 QUIT
+3 ;
MSG ;
+1 SET VALMSG="Patient Data is being edited by another user!"
+2 QUIT
+3 ;
