Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: EASAILK1

EASAILK1.m

Go to the documentation of this file. 
  1. EASAILK1 ;ALB/BRM,ERC,JAM,ARF - Patient Address Inquiry ;18 Jul 2017  4:03 PM
  1.  ;;1.0;ENROLLMENT APPLICATION SYSTEM;**13,29,39,70,151,203**;Mar 15, 2001;Build 17
  1.  ;
  1.  ;*151*; JAM - Add Residential Address and modify Permanent, Confidential, and Temporary address field labels and reformat the output
  1.  ;
  1. PATADDR ;view patient address
  1.  ;
  1.  N PATNAM,IENS,ZTSAVE
  1.  N DTOUT,DUOUT,DIRUT,DIROUT,%ZIS,DIC,DA,DIQ,DLAYGO,Y,X
  1.  ;
  1.  ; prompt user for patient name and device
  1.  S DIC="^DPT(",DIC(0)="AEMQ" D ^DIC
  1.  Q:($D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT)!(Y=-1))
  1.  S %ZIS="Q"
  1.  S IENS=+Y_",",PATNAM=$P(Y,"^",2)
  1.  S ZTSAVE("IENS")="",ZTSAVE("PATNAM")=""
  1.  D EN^XUTMDEVQ("QUE^EASAILK1","PATIENT ADDRESS INQUIRY",.ZTSAVE,.%ZIS)
  1.  Q
  1. QUE ;
  1.  N DGC,CONOK,PATOK,TMPOK,FLD,CONARR,TMPARR,PATARR,CONERR,TMPERR,PATERR
  1.  N CONSTR,TMPSTR,PATSTR,TYPE,CONFARR,TEMPARR
  1.  ;
  1. PAT ;patient address
  1.  N PATOK
  1.  D GETS^DIQ(2,IENS,".111:.121","E","PATARR","PATERR")
  1.  W !?23,"Patient Name: ",?37,PATNAM
  1.  ; exit if error occurs during DIQ call
  1.  ; EAS*1.0*151; JAM; Change label to Permanent Mailing Address 
  1.  ; EAS*1.0*203; ARF; Removed Permanent from the following message
  1.  I $D(PATERR) W !!?11,"There is invalid data in the Mailing Address",!?11,"Please use Registration options to edit",!! G CON
  1.  ;
  1.  ; exit if there is no address for patient
  1.  S FLD="",PATOK=0
  1.  D OK(.PATARR,.PATOK)
  1.  ; EAS*1.0*151; JAM; Change label to Permanent Mailing Address
  1.  ; EAS*1.0*203; ARF; Removed Permanent from the following message
  1.  I 'PATOK W !!?11,"*** No Mailing Address On File For This Patient ***",!! G CON
  1.  ;set a string of the field numbers needed for the patient address
  1.  S PATSTR=".111^.112^.113^.114^.115^.1112^.1173^.121^.118^.119^.12^^^.1171^.1172"
  1.  N STRARR
  1.  D STRG(PATSTR,.STRARR) ;place the fld numbers into an array
  1.  ; EAS*1.0*151; JAM; Change TYPE to "Permanent Mailing" (from "Patient") 
  1.  ; EAS*1.0*203; ARF; Removed "Permanent" from the following TYPE variable 
  1.  S TYPE="          Mailing"
  1.  S DGC=1
  1.  ;display the patient address information
  1.  D DISP(TYPE,.PATARR,.STRARR)
  1.  ;
  1. CON ;confidential address
  1.  N CONARR,CONERR,CONOK,DGJ
  1.  S CONOK=0
  1.  D GETS^DIQ(2,IENS,".141*;.14105;.1411:.142","IE","CONARR","CONERR")
  1.  I $D(CONERR) S CONOK=-1 G TMP
  1.  S FLD=""
  1.  D OK(.CONARR,.CONOK) ;checking for presence of confid address array
  1.  I $G(CONARR(2,IENS,.14105,"E"))'="YES" S CONOK=0 G TMP
  1.  ;treat null end date as if in the future
  1.  I DT'<$G(CONARR(2,IENS,.1417,"I")),$G(CONARR(2,IENS,.1418,"I"))']"" G CON2
  1.  I DT>$G(CONARR(2,IENS,.1418,"I")) S CONOK=0 G TMP ;if date range in the past, don't display
  1.  I DT<$G(CONARR(2,IENS,.1417,"I")) S CONOK=0 G TMP ;if date range in the future, dont display
  1. CON2 ;
  1.  S DGJ=""
  1.  S CONOK=0 ;now check for active E/E confid address
  1.  F  S DGJ=$O(CONARR(2.141,DGJ)) Q:DGJ']""  D
  1.  . I CONARR(2.141,DGJ,.01,"E")["ELIG" D
  1.  . . I CONARR(2.141,DGJ,1,"E")="YES" S CONOK=1
  1.  I 'CONOK G TMP
  1.  ;set string of the field numbers needed for the confidential address
  1.  S CONSTR=".1411^.1412^.1413^.1414^.1415^.1416^.14116^^.14112^^.14113^.1417^.1418^.14114^.14115"
  1.  N CONFARR
  1.  D STRG(.CONSTR,.CONFARR) ;place field numbers into an array
  1.  ;
  1. TMP ;temporary address
  1.  N TMPARR,TMPERR,TMPOK
  1.  S TMPOK=0
  1.  D GETS^DIQ(2,IENS,".12105;.1211:.1219;.1221:.1223","IE","TMPARR","TMPERR")
  1.  ; EAS*1.0*151; JAM; Add Residential Address
  1.  I $D(TMPERR) S TMPOK=-1 G RES
  1.  S FLD=""
  1.  D OK(.TMPARR,.TMPOK) ;check for presence of temp address array
  1.  I 'TMPOK G RES
  1.  I $G(TMPARR(2,IENS,.12105,"E"))'="YES" S TMPOK=0 G RES
  1.  ;treat null end date as if in the future
  1.  I DT'<$G(TMPARR(2,IENS,.1217,"I")),($G(TMPARR(2,IENS,.1218,"I")))']"" G TMP2
  1.  I DT>$G(TMPARR(2,IENS,.1218,"I")) S TMPOK=0 ;if date range in the past, don't display
  1. TMP2 ;
  1.  ; EAS*1.0*151; JAM; Add Residential Address
  1.  I 'TMPOK G RES
  1.  N TEMPARR
  1.  ;set string of the field numbers needed for the temporary address
  1.  S TMPSTR=".1211^.1212^.1213^.1214^.1215^.12112^.1223^^.12113^^.12114^.1217^.1218^.1221^.1222"
  1.  D STRG(.TMPSTR,.TEMPARR) ;place field numbers into an array
  1.  ;
  1.  ; EAS*1.0*151; JAM; Add Residential Address 
  1. RES ;gather residential address
  1.  N RESARR,RESERR,RESOK,RESSTR
  1.  S RESOK=0
  1.  D GETS^DIQ(2,IENS,".1151:.11582","IE","RESARR","RESERR")
  1.  ;D GETS^DIQ(2,IENS,".115*;.14105;.1411:.142","IE","CONARR","CONERR")
  1.  I $D(RESERR) S RESOK=-1 G OPT
  1.  S FLD=""
  1.  D OK(.RESARR,.RESOK) ;checking for presence of residential address array
  1.  ;treat null end date as if in the future
  1.  I DT'<$G(RESARR(2,IENS,.1161,"I")),$G(RESARR(2,IENS,.1162,"I"))']"" G RES2
  1.  I DT>$G(RESARR(2,IENS,.1162,"I")) S RESOK=0 G OPT ;if date range in the past, don't display
  1.  I DT<$G(RESARR(2,IENS,.1161,"I")) S RESOK=0 G OPT ;if date range in the future, dont display
  1. RES2 ;
  1.  I 'RESOK G OPT
  1.  ;set string of the field numbers needed for the residential address
  1.  S RESSTR=".1151^.1152^.1153^.1154^.1155^.1156^.11573^^.1158^.11582^.11581^.1161^.1162^.11571^.11572"
  1.  N RESIDARR
  1.  D STRG(.RESSTR,.RESIDARR) ;place field numbers into an array
  1.  ;
  1. OPT ;let user decide to see confid. a/o temp address, residential address if disp. on screen
  1.  N DGELIG,DGEND,DGOPT,DGPROMPT,DIR,DGRET
  1.  S DGEND=0
  1.  ; EAS*1.0*151; JAM; Add Residential Address to address choices
  1.  I RESOK'=1 D
  1.  .S DGOPT=$S(CONOK=1&(TMPOK=1):3,CONOK=1&(TMPOK=0):2,TMPOK=1&(CONOK=0):1,1:"")
  1.  E  D
  1.  .S DGOPT=$S(CONOK=1&(TMPOK=1):4,CONOK=1&(TMPOK=0):5,TMPOK=1&(CONOK=0):6,1:7)
  1.  I DGOPT']"" S DGOPT=$S(CONOK=-1&(TMPOK=-1):8,CONOK=-1:9,TMPOK=-1:10,1:"")
  1.  ; EAS*1.0*151; JAM; Change label to Confidential and add Residential Address 
  1.  I $G(DGOPT)="" W !?5,PATNAM_" has no Temporary, Confidential or ",!?5,"Residential Address." W !! G END
  1.  I $G(DGOPT)>7 D
  1.  . W !?11,"There is invalid data in the "_$S(DGOPT=8:"Temporary and Confidential ",DGOPT=9:"Confidential ",10:"Temporary ")_"address"_$S(DGOPT=8:"es.",1:".")
  1.  . W !?11,"Please use Registration options to edit.",!!
  1.  I $E(IOST,1,2)["C-" D
  1.  . S DIR(0)="YAO",DIR("B")="Yes"
  1.  . ; EAS*1.0*151; JAM; - change labels from "Elig/Enroll Confidential" to "Conf Mailing" and "Temporary" to "Temp Mailing"
  1.  . ;  and add Residential Address (add logic to test for residential address and add to prompt)
  1.  . S DGELIG="Conf Mailing"
  1.  . S DGPROMPT=$S(DGOPT=3:DGELIG_" and Temp Mailing",DGOPT=2:DGELIG,DGOPT=1:"Temporary Mailing",DGOPT=4:DGELIG_", Temp Mailing and Residential",DGOPT=5:DGELIG_" and Residential",1:"")
  1.  . I $G(DGPROMPT)="" S DGPROMPT=$S(DGOPT=6:"Temporary Mailing and Residential",DGOPT=7:"Residential",1:"")
  1.  . I $G(DGPROMPT)="" S DGEND=1 Q
  1.  . S DIR("A")="Would you like to view the "_DGPROMPT_" Address"_$S((DGOPT>2&(DGOPT<7)):"es",1:"")_"? "
  1.  . D ^DIR K DIR
  1.  . I Y'=1 S DGEND=1
  1.  I DGEND=1 G END
  1.  S DGC=2
  1.  ;
  1.  ;if displayed on screen offer to show addresses and do a page break for readability.
  1.  I DGC>1 D
  1.  . I $E(IOST,1,2)["C-" W @IOF
  1.  . W !!?23,"Patient Name: ",?37,PATNAM
  1.  ;display the addresses that are populated
  1.  ; EAS*1.0*151; JAM; Modify address labels to Confid Mailing and Temp Mailing and add Residential address
  1.  I CONOK=1 S TYPE="   Confid Mailing" D DISP(TYPE,.CONARR,.CONFARR)
  1.  I TMPOK=1 S TYPE="     Temp Mailing" D DISP(TYPE,.TMPARR,.TEMPARR)
  1.  ; DGOPT=4 means all 3 addresses are present, so we should paginate the display prior to displaying residential address
  1.  I DGOPT=4 I $G(IOST)["C-" R !,"Enter <RETURN> to continue.",DGRET:DTIME W !
  1.  I RESOK=1 S TYPE="      Residential" D DISP(TYPE,.RESARR,.RESIDARR)
  1.  ; EAS*1.0*151; JAM; Modify messages to "Confidential Mailing Address" and "Temporary Mailing" and add Residential Address message
  1.  I 'CONOK W !?8,"Patient "_PATNAM_" has no Confidential Mailing Address."
  1.  I 'TMPOK W !?8,"Patient "_PATNAM_" has no Temporary Mailing Address."
  1.  I 'RESOK W !?8,"Patient "_PATNAM_" has no Residential Address."
  1.  W !
  1.  G END
  1.  ;
  1. OK(ARR,OK) ;check for presence of an array
  1.  F  S FLD=$O(ARR(2,IENS,FLD)) Q:'FLD!(OK)  S:$G(ARR(2,IENS,FLD,"E"))]"" OK=1
  1.  Q
  1.  ;
  1. STRG(STR,STRARR) ;set the field string into an array
  1.  N DGD
  1.  F DGD=1:1:15  S STRARR(DGD)=$P(STR,U,DGD)
  1.  Q
  1.  ;
  1.  ;display address information
  1. DISP(TYPE,ARR,STR) ;
  1.  N DGCNTRY,DGUSA
  1.  S DGUSA=0 ;I country=USA or "" display state/zip, E prov/postal code
  1.  S:$G(ARR(2,IENS,$G(STR(7)),"E"))="USA" DGUSA=1
  1.  S:$G(ARR(2,IENS,$G(STR(7)),"E"))']"" DGUSA=1
  1.  W !?10,TYPE_" Address: ",?37,$S($G(ARR(2,IENS,$G(STR(1)),"E"))]"":ARR(2,IENS,STR(1),"E"),1:"UNKNOWN STREET ADDRESS")
  1.  W:$G(ARR(2,IENS,$G(STR(2)),"E"))]"" !?37,ARR(2,IENS,STR(2),"E")
  1.  W:$G(ARR(2,IENS,STR(3),"E"))]"" !?37,ARR(2,IENS,STR(3),"E")
  1.  I DGUSA D  ;US address or null country which defaults to US
  1.  . W !?37,$S($G(ARR(2,IENS,STR(4),"E"))]"":ARR(2,IENS,STR(4),"E"),1:"UNKNOWN CITY")_", "
  1.  . W $S($G(ARR(2,IENS,STR(5),"E"))]"":ARR(2,IENS,STR(5),"E"),1:"UNKNOWN STATE")_" "
  1.  . W:$G(ARR(2,IENS,STR(6),"E"))]"" ARR(2,IENS,STR(6),"E")
  1.  I 'DGUSA D  ;foreign address
  1.  . W !?37,""
  1.  . W:$G(ARR(2,IENS,STR(15),"E"))]"" ARR(2,IENS,STR(15),"E")_" "
  1.  . W $S($G(ARR(2,IENS,STR(4),"E"))]"":ARR(2,IENS,STR(4),"E"),1:"UNKNOWN CITY")_", "
  1.  . W $S($G(ARR(2,IENS,STR(14),"E"))]"":ARR(2,IENS,STR(14),"E"),1:"UNKNOWN PROVINCE")_" "
  1.  I $G(ARR(2,IENS,STR(7),"E"))]"" D
  1.  . S DGCNTRY=ARR(2,IENS,STR(7),"E")
  1.  . S DGCNTRY=$$COUNTRY^DGADDUTL(.DGCNTRY)
  1.  . W !?37,DGCNTRY
  1.  ; EAS*1.0*151; JAM; TYPE is modified from "Patient" to "Permanent Mailing" and new address type "Residential"
  1.  ; EAS*1.0*203 ; ARF; TYPE is modified from "Permanent" to "  Mailing" 
  1.  I TYPE["  Mailing" W !?14,"Bad Address Indicator: ",?37,$G(ARR(2,IENS,STR(8),"E"))
  1.  W !?2,TYPE_" Add Change Date: ",?37,$G(ARR(2,IENS,STR(9),"E"))
  1.  I TYPE["  Mailing" W !?10,"Mailing Add Change Source: ",?37,$G(ARR(2,IENS,STR(10),"E"))
  1.  I TYPE["Residential" W !,TYPE_" Add Change Source: ",?37,$G(ARR(2,IENS,STR(10),"E"))
  1.  I TYPE["  Mailing" W:$G(ARR(2,IENS,STR(10),"E"))="VAMC" !?2,TYPE_" Add Change Site: ",?37,$G(ARR(2,IENS,STR(11),"E"))
  1.  I TYPE'["  Mailing" W:$G(ARR(2,IENS,STR(11),"E"))]"" !?2,TYPE_" Add Change Site: ",?37,$G(ARR(2,IENS,STR(11),"E"))
  1.  I TYPE'["  Mailing",TYPE'["Residential" W !?3,TYPE_" Add Start Date: ",?37,$G(ARR(2,IENS,STR(12),"E"))
  1.  I TYPE'["  Mailing",TYPE'["Residential" W !?5,TYPE_" Add End Date: ",?37,$G(ARR(2,IENS,STR(13),"E"))
  1.  W !
  1.  Q
  1.  ;
  1. END ; common exit point - reset device and prompt user for another name
  1.  K %ZIS D ^%ZISC,HOME^%ZIS
  1.  G PATADDR
  1.  Q