- DGADDUTL ;ALB/PHH,EG,BAJ,ERC,CKN,TDM,LBD,JAM,ARF - PATIENT ADDRESS ; 19 Jul 2017 3:03 PM
- ;;5.3;Registration;**658,695,730,688,808,851,872,915,925,941,1010,1040,1056**;Aug 13, 1993;Build 18
- Q
- ADDR ; validate/edit Patient address (entry for DG ADDRESS UPDATE option)
- N %,QUIT,DIC,Y,DFN,USERSEL
- ADDRLOOP ;
- N X,DGLN,DGCNT,DGLINE,DIWL,DIWR,DIWF ;DG*5.3*1056
- W !!
- K DIC,Y,DFN,USERSEL
- S DIC="^DPT(",DIC(0)="AEMZQ",DIC("A")="Veteran Name/SSN: " D ^DIC
- I $D(DTOUT)!($D(DUOUT)) Q
- Q:Y'>0
- ;
- S DFN=+Y,QUIT=0
- L +^DPT(DFN):3 E W !!,"Patient is being edited. Try again later." G ADDR
- F D Q:QUIT
- .; JAM - Patch DG*5.3*941 Modify prompt to add "Mailing"
- .; Patch DG*5.3*1056 Remove (P)ermanent from the following prompt, changed to (M)ailing
- .W !!
- .S X="Do you want to update the (M)ailing Address, (T)emporary Mailing Address, or (B)oth? "
- . ;Patch DG*5.3*1056 - use DIWP to format the prompt
- .K ^UTILITY($J,"W") S DIWL=0,DIWR=79,DIWF="" D ^DIWP
- .S DGCNT=^UTILITY($J,"W",0)
- .F DGLN=1:1:DGCNT S DGLINE=$TR(^UTILITY($J,"W",0,DGLN,0),"_"," ") W !,DGLINE
- .K ^UTILITY($J,"W")
- .R USERSEL:300
- .I '$T S USERSEL="^"
- .I USERSEL["^"!(USERSEL="") S QUIT=1 Q
- .S USERSEL=$TR(USERSEL,"mtb","MTB") ;DG*5.3*1056 added M for Mailing Address and removed P(ermanent)
- .I USERSEL'="M",USERSEL'="T",USERSEL'="B" D Q ;DG*5.3*1056 added M for Mailing Address and removed P(ermanent)
- ..W !,"Invalid selection!"
- .I (USERSEL="M")!(USERSEL="B") W ! D UPDATE(DFN,"PERM") ;DG*5.3*1056 added M for Mailing Address and removed P(ermanent)
- .I USERSEL="T"!(USERSEL="B") D UPDATE(DFN,"TEMP")
- .S QUIT=1
- L -^DPT(DFN)
- G ADDRLOOP
- ADD(DFN) ; validate/edit Patient address (entry point for routine DGREG)
- ; Input -- DFN
- ;
- ; DG*5.3*1040 - New variable DGADDFG to track called from entry point ADD
- N RETVAL,ADDYN,DGADDFG S DGADDFG=1
- ;Display the mailing address (DG*5.3*851)
- D DISPADD^DGADDUT2(DFN)
- S (RETVAL,ADDYN)=0
- F D Q:ADDYN
- .;jam DG*5.3*925 RM#788099 Add/Edit Residential address - Change prompt to Permanent Mailing Address:
- .;DG*5.3*1056 removed Permanent from the following prompt
- .S ADDYN=$$ADDYN("Do you want to edit the Patient's Mailing Address")
- .S RETVAL=ADDYN
- .I ADDYN'=1,ADDYN'=2 S (ADDYN,RETVAL)=0
- .I 'ADDYN W !?5,"Enter 'YES' to edit Patient's Address or 'NO' to continue."
- I ADDYN=1,$G(DFN)'="",$D(^DPT(DFN,0)) D
- .D UPDATE(DFN,"PERM")
- .; DG*5.3*1040 - Check if DGTMOT exists and return -1
- .I +$G(DGTMOT) S RETVAL=-1
- .E S RETVAL=1
- Q RETVAL
- ADDYN(PROMPT) ; Yes/No Prompt to Edit/Validate Address
- ; Input -- None
- ; Output -- 1 = YES
- ; 2 = NO
- ; -1 = Aborted
- ;
- N %
- W !,PROMPT
- D YN^DICN
- Q %
- UPDATE(DFN,TYPE) ; Update the Address
- ; Input -- TYPE = "PERM" for Permanent Address
- ; = "TEMP" for Temporary Address
- ; Output -- None
- ;
- I TYPE'="PERM",TYPE'="TEMP" Q
- I TYPE="PERM" D
- .W !
- .; JAM DG*5.3*941, Home and Office phone numbers not associated with Perm Address, so set FLG(1)=0 so we don't edit these fields here
- .N FLG S FLG(1)=0,FLG(2)=1
- .D ADDRED(DFN,.FLG)
- ;
- I TYPE="TEMP" D
- .D EDITTADR(DFN)
- ;
- Q
- UPDDTTM(DFN,TYPE) ; Update the PATIENT file #2 with the current date and time
- ;
- D UPDDTTM^DGADDUT2(DFN,TYPE)
- Q
- ADDRED(DFN,FLG) ; Address Edit (Code copied from DGREGAED and modified)
- ;Input:
- ; DFN (required) - Internal Entry # of Patient File (#2)
- ; FLG (optional) - Flags of 1 or 0; if null, 0 is assumed. Details:
- ; FLG(1) - if 1, let user edit phone numbers (field #.131 and #.132)
- ; FLG(2) - if 1, display before & after address for user confirmation
- N SRC,%,DGINPUT,I,X,Y
- I '$G(DGADDFG) N DGTMOT S DGTMOT=0 ; DG*5.3*1040 - New only coming from entry point UPDATE directly
- S SRC="ADDUTL"
- D EN^DGREGAED(DFN,.FLG,SRC)
- ;
- ; DG*5.3*1040; jam; If timeout and this is a direct call to UPDATE, clear the screen prior to quitting
- I $G(DGTMOT),'$G(DGADDFG) W @IOF,!!!
- ;
- ; Update the Date/Time Stamp
- ;The next line was disabled to fix problem of Date/Time stamp being
- ;updated even if no changes were made (DG*5.3*851).
- ;D UPDDTTM(DFN,TYPE)
- Q
- GETPRIOR(DFN,DGPRIOR) ; Get prior address fields.
- N DGCURR,DGN,DGARRY,DGCIEN,DGST,DGCNTY
- D GETS^DIQ(2,DFN_",",".111;.112;.113;.114;.115;.117;.1112;.131;.132;.121;.118;.119;.12;.122;.1171:.1173","I","DGCURR")
- F DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.121,.118,.119,.12,.122,.1171,.1172,.1173 D
- . S DGARRY("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"I"))
- M DGPRIOR=DGARRY("OLD")
- Q
- GETUPDTS(DFN,DGINPUT) ; Get current address fields.
- N DGCURR,DGN,DGARRY
- D GETS^DIQ(2,DFN_",",".118;.119;.12;.122","I","DGCURR")
- F DGN=.118,.119,.12,.122 D
- . S DGARRY("NEW",DGN)=$G(DGCURR(2,DFN_",",DGN,"I"))
- M DGINPUT=DGARRY("NEW")
- Q
- FILEYN(DGOLD,DGNEW) ; Determine whether or not to file to #301.7
- N RETVAL
- S RETVAL=0
- D
- .I DGOLD(.111)'=$G(DGNEW(.111)) S RETVAL=1 Q
- .I DGOLD(.112)'=$G(DGNEW(.112)) S RETVAL=1 Q
- .I DGOLD(.113)'=$G(DGNEW(.113)) S RETVAL=1 Q
- .I DGOLD(.114)'=$G(DGNEW(.114)) S RETVAL=1 Q
- .I DGOLD(.115)'=$P($G(DGNEW(.115)),"^",2) S RETVAL=1 Q
- .I DGOLD(.1112)'=$G(DGNEW(.1112)) S RETVAL=1 Q
- .I DGOLD(.117)'=$P($G(DGNEW(.117)),"^",2) S RETVAL=1 Q
- .I DGOLD(.131)'=$G(DGNEW(.131)) S RETVAL=1 Q
- .I DGOLD(.1171)'=$G(DGNEW(.1171)) S RETVAL=1 Q
- .I DGOLD(.1172)'=$G(DGNEW(.1172)) S RETVAL=1 Q
- .I DGOLD(.1173)'=$P($G(DGNEW(.1173)),"^",2) S RETVAL=1 Q
- .I DGOLD(.121)'=$G(DGNEW(.121)) S RETVAL=1 Q
- Q RETVAL
- FOREIGN(DFN,CIEN,FILE,FIELD,COUNTRY) ;
- ; ** NOTE we have to default the value for "US" into the prompt if it is blank
- N FORGN,DA,DIR,DTOUT,DUOUT,DIROUT,DONE,INDX
- S:'$G(FILE) FILE=2 I '$G(FIELD) S FIELD=.1173
- S DIR(0)=FILE_","_FIELD,DONE=0 S:DFN DA=DFN
- S DIR("B")=$E($$CNTRYI^DGADDUTL(CIEN),1,19) I DIR("B")=-1 S DIR("B")="UNKNOWN COUNTRY"
- F D Q:DONE
- . D ^DIR
- . I $D(DTOUT) S DONE=1,FORGN=-1 Q
- . I $D(DUOUT)!$D(DIROUT) W !,"EXIT NOT ALLOWED" Q
- . I $D(DIRUT) W !,"This is a required response." Q
- . S COUNTRY=$P($G(Y),"^",2),FORGN=$$FORIEN($P($G(Y),"^")),DONE=1
- Q FORGN
- UPDADDLG(DFN,DGPRIOR,DGINPUT) ; Update the IVM ADDRESS CHANGE LOG file #301.7
- ;
- D UPDADDLG^DGADDUT2(DFN,.DGPRIOR,.DGINPUT)
- Q
- EDITTADR(DFN) ; Edit Temporary Address
- N DGPRIOR,DGCH,DGRPAN,DGDR,DGRPS
- I $G(DFN)="" Q
- ;I ($G(DFN)'?.N) Q
- ;
- ; Get the current Temporary Address and display it
- D GETTADR(DFN,.DGPRIOR)
- D DISPTADR(DFN,.DGPRIOR)
- W !!
- ;
- I '$G(DGADDFG) N DGTMOT S DGTMOT=0 ; DG*5.3*1040 - New only coming from entry point UPDATE directly
- ;
- ; JAM - Patch DG*5.3*941 - Temporary Mailing Address is editable via screen 1.1 group 3 (from screen 1 group 5)
- ;S DGCH=5,DGRPAN="1,2,3,4,5,",DGDR="",DGRPS=1
- S DGCH=3,DGRPAN="1,2,3,4,5",DGDR="",DGRPS=1.1
- D CHOICE^DGRPP
- D ^DGRPE
- ; DG*5.3*1040; jam; If timeout and this is a direct call to UPDATE, clear the screen prior to quitting
- I $G(DGTMOT),'$G(DGADDFG) W @IOF,!!! Q
- ; Update the Date/Time Stamp
- D UPDDTTM(DFN,TYPE)
- Q
- GETTADR(DFN,DGPRIOR) ; Get prior temporary address fields.
- N DGCURR,DGN,DGARRY,DGCIEN,DGST,DGCNTY
- D GETS^DIQ(2,DFN_",",".1211;.1212;.1213;.1214;.1215;.1216;.1217;.1218;.12105;.1219;.12111;.12112;.12113;.12114;.1221:.1223","I","DGCURR")
- F DGN=.1211,.1212,.1213,.1214,.1215,.1216,.1217,.1218,.12105,.1219,.12111,.12112,.12113,.12114,.1221,.1222,.1223 D
- .S DGARRY("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"I"))
- M DGPRIOR=DGARRY("OLD")
- Q
- DISPTADR(DFN,DGARRY) ; Display Temporary Address
- N DGADRACT,DGADR1,DGADR2,DGADR3,DGCITY,DGSTATE,DGZIP
- N DGCOUNTY,DGPHONE,DGFROMDT,DGTODT,DGPROV,DGPCODE,DGCNTRY,DGFORN
- ;
- S DGADRACT=$G(DGARRY(.12105))
- S DGADR1=$G(DGARRY(.1211))
- S DGADR2=$G(DGARRY(.1212))
- S DGADR3=$G(DGARRY(.1213))
- S DGCITY=$G(DGARRY(.1214))
- S DGSTATE=$G(DGARRY(.1215))
- S DGZIP=$G(DGARRY(.1216))
- S DGCOUNTY=$G(DGARRY(.12111))
- I DGCOUNTY'="",DGSTATE'="",$D(^DIC(5,DGSTATE,1,DGCOUNTY,0)) D
- .S DGCOUNTY=$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^")_$S($P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)'="":"("_$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)_")",1:"")
- ;changing to remove display of empty (), will only display if a code is in the 4th piece of the state file-Patch 872
- ;S DGCOUNTY=$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^")_"( "_$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)
- I DGADRACT'="Y" S DGCOUNTY="NOT APPLICABLE"
- I DGSTATE'="",$D(^DIC(5,DGSTATE,0)) S DGSTATE=$P(^DIC(5,DGSTATE,0),"^",2)
- S DGPROV=$G(DGARRY(.1221))
- S DGPCODE=$G(DGARRY(.1222))
- S DGCNTRY=$G(DGARRY(.1223))
- S DGFORN=$$FORIEN(DGCNTRY)
- I DGCNTRY]"" S DGCNTRY=$$CNTRYI(DGCNTRY)
- S DGPHONE=$G(DGARRY(.1219))
- S DGFROMDT=$$FMTE^XLFDT($G(DGARRY(.1217)))
- S DGTODT=$$FMTE^XLFDT($G(DGARRY(.1218)))
- ;
- ;jam DG*5.3*925 RM#788099 Add/Edit Residential address - Change field label to Temporary Mailing Address:
- W !!,"Temporary Mailing Address: "
- I DGADRACT="Y" D
- .W:DGADR1'="" !?9,DGADR1
- .W:DGADR2'="" !?9,DGADR2
- .W:DGADR3'="" !?9,DGADR3
- .I DGFORN=0 D
- ..W !?9,$S(DGCITY'="":DGCITY,1:"")_$S(DGCITY'="":",",1:" ")_$S(DGSTATE'="":DGSTATE,1:"")_" "_$S(DGZIP'="":DGZIP,1:"")
- .;I DGFORN W !?8,$S(DGPCODE'="":DGPCODE,1:"")_" "_$S(DGCITY'="":DGCITY,1:"")_$S(DGCITY'="":",",1:" ")_$S(DGPROV'="":DGPROV,1:"") ;DG*1010 comment out
- .I DGFORN W !?8,$S(DGCITY'="":DGCITY,1:"")_$S(DGCITY'="":",",1:" ")_$S(DGPROV'="":DGPROV,1:"")_" "_$S(DGPCODE'="":DGPCODE,1:"") ;DG*1010 - display postal code last
- ;commenting out, causes address to print 2x. Patch 872
- ;W !?9,$S(DGCITY'="":DGCITY,1:"")_","_$S(DGSTATE'="":DGSTATE,1:"")_" "_$S(DGZIP'="":DGZIP,1:"")
- ;Removing lines from dot structure Patch 872
- W !," County: "_DGCOUNTY
- W !," Phone: "_DGPHONE
- W !,"From/To: "_$P(DGFROMDT,",")_","_$P(DGFROMDT,", ",2)_"-"_$P(DGTODT,",")_","_$P(DGTODT,", ",2)
- ;
- I $G(DGARRY(.12105))="N" D
- .W:$G(DGARRY(.1211))="" !?9,"NO TEMPORARY ADDRESS"
- .W:$G(DGARRY(.1212))="" !?9,""
- .W !," County: NOT APPLICABLE"
- .W !," Phone: NOT APPLICABLE"
- .W !,"From/To: NOT APPLICABLE"
- Q
- COUNTRY(DGC) ;
- ;where DGC is the external value of the country
- ;return value is in upper case display mode
- ;if DGC is invalid, return -1
- N DGCC,DGIEN
- ; if input is NULL change to US
- I $G(DGC)="" S DGC="USA"
- ; Get IEN from B index, error if not found
- S DGIEN=$O(^HL(779.004,"B",DGC,"")) Q:DGIEN']"" -1
- ; xlate IEN to POSTAL NAME
- S DGCC=$P(^HL(779.004,DGIEN,"SDS"),U,3)
- ; if POSTAL NAME = "<NULL>" return DESCRIPTION
- I DGCC="<NULL>" D
- . S DGCC=$$UPPER^DGUTL($P(^HL(779.004,DGIEN,0),U,2))
- Q DGCC
- FOR(DGC) ;returns a 1 if address is foreign, a 0 if domestic, -1 if DGC is not valid
- ; DGC is the external value of the country (.01 field of file 779.004)
- N DGFOR
- S DGFOR=0
- I $G(DGC)="" Q DGFOR
- I '$D(^HL(779.004,"B",DGC)) Q -1
- I DGC'="USA" S DGFOR=1
- Q DGFOR
- CNTRYI(DGIEN) ;where DGC is the internal value of the country
- ;return DGC as the display value for the country
- ;if the input value is not a valid IEN, return -1
- ;if the input value is null, return null
- N DGCC
- I $G(DGIEN)="" Q ""
- I '$D(^HL(779.004,DGIEN,0)) Q -1
- ; xlate IEN to POSTAL NAME
- S DGCC=$P(^HL(779.004,DGIEN,"SDS"),U,3)
- ; if POSTAL NAME = "<NULL>" return DESCRIPTION
- I DGCC="<NULL>" D
- . S DGCC=$$UPPER^DGUTL($P(^HL(779.004,DGIEN,0),U,2))
- Q DGCC
- FORIEN(DGC) ;returns a 1 if address is foreign, a 0 if domestic, -1 if DGC is invalid
- ;DGC is the IEN of the country file (#779.004)
- N DGFOR
- S DGFOR=0
- I $G(DGC)="" Q DGFOR
- I DGC'?1.3N Q -1
- I '$D(^HL(779.004,DGC,0)) Q -1
- I DGC]"",(DGC'=$O(^HL(779.004,"B","USA",""))) S DGFOR=1
- Q DGFOR
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGADDUTL 11621 printed Jan 18, 2025@03:41:51 Page 2
- DGADDUTL ;ALB/PHH,EG,BAJ,ERC,CKN,TDM,LBD,JAM,ARF - PATIENT ADDRESS ; 19 Jul 2017 3:03 PM
- +1 ;;5.3;Registration;**658,695,730,688,808,851,872,915,925,941,1010,1040,1056**;Aug 13, 1993;Build 18
- +2 QUIT
- ADDR ; validate/edit Patient address (entry for DG ADDRESS UPDATE option)
- +1 NEW %,QUIT,DIC,Y,DFN,USERSEL
- ADDRLOOP ;
- +1 ;DG*5.3*1056
- NEW X,DGLN,DGCNT,DGLINE,DIWL,DIWR,DIWF
- +2 WRITE !!
- +3 KILL DIC,Y,DFN,USERSEL
- +4 SET DIC="^DPT("
- SET DIC(0)="AEMZQ"
- SET DIC("A")="Veteran Name/SSN: "
- DO ^DIC
- +5 IF $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +6 if Y'>0
- QUIT
- +7 ;
- +8 SET DFN=+Y
- SET QUIT=0
- +9 LOCK +^DPT(DFN):3
- IF '$TEST
- WRITE !!,"Patient is being edited. Try again later."
- GOTO ADDR
- +10 FOR
- Begin DoDot:1
- +11 ; JAM - Patch DG*5.3*941 Modify prompt to add "Mailing"
- +12 ; Patch DG*5.3*1056 Remove (P)ermanent from the following prompt, changed to (M)ailing
- +13 WRITE !!
- +14 SET X="Do you want to update the (M)ailing Address, (T)emporary Mailing Address, or (B)oth? "
- +15 ;Patch DG*5.3*1056 - use DIWP to format the prompt
- +16 KILL ^UTILITY($JOB,"W")
- SET DIWL=0
- SET DIWR=79
- SET DIWF=""
- DO ^DIWP
- +17 SET DGCNT=^UTILITY($JOB,"W",0)
- +18 FOR DGLN=1:1:DGCNT
- SET DGLINE=$TRANSLATE(^UTILITY($JOB,"W",0,DGLN,0),"_"," ")
- WRITE !,DGLINE
- +19 KILL ^UTILITY($JOB,"W")
- +20 READ USERSEL:300
- +21 IF '$TEST
- SET USERSEL="^"
- +22 IF USERSEL["^"!(USERSEL="")
- SET QUIT=1
- QUIT
- +23 ;DG*5.3*1056 added M for Mailing Address and removed P(ermanent)
- SET USERSEL=$TRANSLATE(USERSEL,"mtb","MTB")
- +24 ;DG*5.3*1056 added M for Mailing Address and removed P(ermanent)
- IF USERSEL'="M"
- IF USERSEL'="T"
- IF USERSEL'="B"
- Begin DoDot:2
- +25 WRITE !,"Invalid selection!"
- End DoDot:2
- QUIT
- +26 ;DG*5.3*1056 added M for Mailing Address and removed P(ermanent)
- IF (USERSEL="M")!(USERSEL="B")
- WRITE !
- DO UPDATE(DFN,"PERM")
- +27 IF USERSEL="T"!(USERSEL="B")
- DO UPDATE(DFN,"TEMP")
- +28 SET QUIT=1
- End DoDot:1
- if QUIT
- QUIT
- +29 LOCK -^DPT(DFN)
- +30 GOTO ADDRLOOP
- ADD(DFN) ; validate/edit Patient address (entry point for routine DGREG)
- +1 ; Input -- DFN
- +2 ;
- +3 ; DG*5.3*1040 - New variable DGADDFG to track called from entry point ADD
- +4 NEW RETVAL,ADDYN,DGADDFG
- SET DGADDFG=1
- +5 ;Display the mailing address (DG*5.3*851)
- +6 DO DISPADD^DGADDUT2(DFN)
- +7 SET (RETVAL,ADDYN)=0
- +8 FOR
- Begin DoDot:1
- +9 ;jam DG*5.3*925 RM#788099 Add/Edit Residential address - Change prompt to Permanent Mailing Address:
- +10 ;DG*5.3*1056 removed Permanent from the following prompt
- +11 SET ADDYN=$$ADDYN("Do you want to edit the Patient's Mailing Address")
- +12 SET RETVAL=ADDYN
- +13 IF ADDYN'=1
- IF ADDYN'=2
- SET (ADDYN,RETVAL)=0
- +14 IF 'ADDYN
- WRITE !?5,"Enter 'YES' to edit Patient's Address or 'NO' to continue."
- End DoDot:1
- if ADDYN
- QUIT
- +15 IF ADDYN=1
- IF $GET(DFN)'=""
- IF $DATA(^DPT(DFN,0))
- Begin DoDot:1
- +16 DO UPDATE(DFN,"PERM")
- +17 ; DG*5.3*1040 - Check if DGTMOT exists and return -1
- +18 IF +$GET(DGTMOT)
- SET RETVAL=-1
- +19 IF '$TEST
- SET RETVAL=1
- End DoDot:1
- +20 QUIT RETVAL
- ADDYN(PROMPT) ; Yes/No Prompt to Edit/Validate Address
- +1 ; Input -- None
- +2 ; Output -- 1 = YES
- +3 ; 2 = NO
- +4 ; -1 = Aborted
- +5 ;
- +6 NEW %
- +7 WRITE !,PROMPT
- +8 DO YN^DICN
- +9 QUIT %
- UPDATE(DFN,TYPE) ; Update the Address
- +1 ; Input -- TYPE = "PERM" for Permanent Address
- +2 ; = "TEMP" for Temporary Address
- +3 ; Output -- None
- +4 ;
- +5 IF TYPE'="PERM"
- IF TYPE'="TEMP"
- QUIT
- +6 IF TYPE="PERM"
- Begin DoDot:1
- +7 WRITE !
- +8 ; JAM DG*5.3*941, Home and Office phone numbers not associated with Perm Address, so set FLG(1)=0 so we don't edit these fields here
- +9 NEW FLG
- SET FLG(1)=0
- SET FLG(2)=1
- +10 DO ADDRED(DFN,.FLG)
- End DoDot:1
- +11 ;
- +12 IF TYPE="TEMP"
- Begin DoDot:1
- +13 DO EDITTADR(DFN)
- End DoDot:1
- +14 ;
- +15 QUIT
- UPDDTTM(DFN,TYPE) ; Update the PATIENT file #2 with the current date and time
- +1 ;
- +2 DO UPDDTTM^DGADDUT2(DFN,TYPE)
- +3 QUIT
- ADDRED(DFN,FLG) ; Address Edit (Code copied from DGREGAED and modified)
- +1 ;Input:
- +2 ; DFN (required) - Internal Entry # of Patient File (#2)
- +3 ; FLG (optional) - Flags of 1 or 0; if null, 0 is assumed. Details:
- +4 ; FLG(1) - if 1, let user edit phone numbers (field #.131 and #.132)
- +5 ; FLG(2) - if 1, display before & after address for user confirmation
- +6 NEW SRC,%,DGINPUT,I,X,Y
- +7 ; DG*5.3*1040 - New only coming from entry point UPDATE directly
- IF '$GET(DGADDFG)
- NEW DGTMOT
- SET DGTMOT=0
- +8 SET SRC="ADDUTL"
- +9 DO EN^DGREGAED(DFN,.FLG,SRC)
- +10 ;
- +11 ; DG*5.3*1040; jam; If timeout and this is a direct call to UPDATE, clear the screen prior to quitting
- +12 IF $GET(DGTMOT)
- IF '$GET(DGADDFG)
- WRITE @IOF,!!!
- +13 ;
- +14 ; Update the Date/Time Stamp
- +15 ;The next line was disabled to fix problem of Date/Time stamp being
- +16 ;updated even if no changes were made (DG*5.3*851).
- +17 ;D UPDDTTM(DFN,TYPE)
- +18 QUIT
- GETPRIOR(DFN,DGPRIOR) ; Get prior address fields.
- +1 NEW DGCURR,DGN,DGARRY,DGCIEN,DGST,DGCNTY
- +2 DO GETS^DIQ(2,DFN_",",".111;.112;.113;.114;.115;.117;.1112;.131;.132;.121;.118;.119;.12;.122;.1171:.1173","I","DGCURR")
- +3 FOR DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.121,.118,.119,.12,.122,.1171,.1172,.1173
- Begin DoDot:1
- +4 SET DGARRY("OLD",DGN)=$GET(DGCURR(2,DFN_",",DGN,"I"))
- End DoDot:1
- +5 MERGE DGPRIOR=DGARRY("OLD")
- +6 QUIT
- GETUPDTS(DFN,DGINPUT) ; Get current address fields.
- +1 NEW DGCURR,DGN,DGARRY
- +2 DO GETS^DIQ(2,DFN_",",".118;.119;.12;.122","I","DGCURR")
- +3 FOR DGN=.118,.119,.12,.122
- Begin DoDot:1
- +4 SET DGARRY("NEW",DGN)=$GET(DGCURR(2,DFN_",",DGN,"I"))
- End DoDot:1
- +5 MERGE DGINPUT=DGARRY("NEW")
- +6 QUIT
- FILEYN(DGOLD,DGNEW) ; Determine whether or not to file to #301.7
- +1 NEW RETVAL
- +2 SET RETVAL=0
- +3 Begin DoDot:1
- +4 IF DGOLD(.111)'=$GET(DGNEW(.111))
- SET RETVAL=1
- QUIT
- +5 IF DGOLD(.112)'=$GET(DGNEW(.112))
- SET RETVAL=1
- QUIT
- +6 IF DGOLD(.113)'=$GET(DGNEW(.113))
- SET RETVAL=1
- QUIT
- +7 IF DGOLD(.114)'=$GET(DGNEW(.114))
- SET RETVAL=1
- QUIT
- +8 IF DGOLD(.115)'=$PIECE($GET(DGNEW(.115)),"^",2)
- SET RETVAL=1
- QUIT
- +9 IF DGOLD(.1112)'=$GET(DGNEW(.1112))
- SET RETVAL=1
- QUIT
- +10 IF DGOLD(.117)'=$PIECE($GET(DGNEW(.117)),"^",2)
- SET RETVAL=1
- QUIT
- +11 IF DGOLD(.131)'=$GET(DGNEW(.131))
- SET RETVAL=1
- QUIT
- +12 IF DGOLD(.1171)'=$GET(DGNEW(.1171))
- SET RETVAL=1
- QUIT
- +13 IF DGOLD(.1172)'=$GET(DGNEW(.1172))
- SET RETVAL=1
- QUIT
- +14 IF DGOLD(.1173)'=$PIECE($GET(DGNEW(.1173)),"^",2)
- SET RETVAL=1
- QUIT
- +15 IF DGOLD(.121)'=$GET(DGNEW(.121))
- SET RETVAL=1
- QUIT
- End DoDot:1
- +16 QUIT RETVAL
- FOREIGN(DFN,CIEN,FILE,FIELD,COUNTRY) ;
- +1 ; ** NOTE we have to default the value for "US" into the prompt if it is blank
- +2 NEW FORGN,DA,DIR,DTOUT,DUOUT,DIROUT,DONE,INDX
- +3 if '$GET(FILE)
- SET FILE=2
- IF '$GET(FIELD)
- SET FIELD=.1173
- +4 SET DIR(0)=FILE_","_FIELD
- SET DONE=0
- if DFN
- SET DA=DFN
- +5 SET DIR("B")=$EXTRACT($$CNTRYI^DGADDUTL(CIEN),1,19)
- IF DIR("B")=-1
- SET DIR("B")="UNKNOWN COUNTRY"
- +6 FOR
- Begin DoDot:1
- +7 DO ^DIR
- +8 IF $DATA(DTOUT)
- SET DONE=1
- SET FORGN=-1
- QUIT
- +9 IF $DATA(DUOUT)!$DATA(DIROUT)
- WRITE !,"EXIT NOT ALLOWED"
- QUIT
- +10 IF $DATA(DIRUT)
- WRITE !,"This is a required response."
- QUIT
- +11 SET COUNTRY=$PIECE($GET(Y),"^",2)
- SET FORGN=$$FORIEN($PIECE($GET(Y),"^"))
- SET DONE=1
- End DoDot:1
- if DONE
- QUIT
- +12 QUIT FORGN
- UPDADDLG(DFN,DGPRIOR,DGINPUT) ; Update the IVM ADDRESS CHANGE LOG file #301.7
- +1 ;
- +2 DO UPDADDLG^DGADDUT2(DFN,.DGPRIOR,.DGINPUT)
- +3 QUIT
- EDITTADR(DFN) ; Edit Temporary Address
- +1 NEW DGPRIOR,DGCH,DGRPAN,DGDR,DGRPS
- +2 IF $GET(DFN)=""
- QUIT
- +3 ;I ($G(DFN)'?.N) Q
- +4 ;
- +5 ; Get the current Temporary Address and display it
- +6 DO GETTADR(DFN,.DGPRIOR)
- +7 DO DISPTADR(DFN,.DGPRIOR)
- +8 WRITE !!
- +9 ;
- +10 ; DG*5.3*1040 - New only coming from entry point UPDATE directly
- IF '$GET(DGADDFG)
- NEW DGTMOT
- SET DGTMOT=0
- +11 ;
- +12 ; JAM - Patch DG*5.3*941 - Temporary Mailing Address is editable via screen 1.1 group 3 (from screen 1 group 5)
- +13 ;S DGCH=5,DGRPAN="1,2,3,4,5,",DGDR="",DGRPS=1
- +14 SET DGCH=3
- SET DGRPAN="1,2,3,4,5"
- SET DGDR=""
- SET DGRPS=1.1
- +15 DO CHOICE^DGRPP
- +16 DO ^DGRPE
- +17 ; DG*5.3*1040; jam; If timeout and this is a direct call to UPDATE, clear the screen prior to quitting
- +18 IF $GET(DGTMOT)
- IF '$GET(DGADDFG)
- WRITE @IOF,!!!
- QUIT
- +19 ; Update the Date/Time Stamp
- +20 DO UPDDTTM(DFN,TYPE)
- +21 QUIT
- GETTADR(DFN,DGPRIOR) ; Get prior temporary address fields.
- +1 NEW DGCURR,DGN,DGARRY,DGCIEN,DGST,DGCNTY
- +2 DO GETS^DIQ(2,DFN_",",".1211;.1212;.1213;.1214;.1215;.1216;.1217;.1218;.12105;.1219;.12111;.12112;.12113;.12114;.1221:.1223","I","DGCURR")
- +3 FOR DGN=.1211,.1212,.1213,.1214,.1215,.1216,.1217,.1218,.12105,.1219,.12111,.12112,.12113,.12114,.1221,.1222,.1223
- Begin DoDot:1
- +4 SET DGARRY("OLD",DGN)=$GET(DGCURR(2,DFN_",",DGN,"I"))
- End DoDot:1
- +5 MERGE DGPRIOR=DGARRY("OLD")
- +6 QUIT
- DISPTADR(DFN,DGARRY) ; Display Temporary Address
- +1 NEW DGADRACT,DGADR1,DGADR2,DGADR3,DGCITY,DGSTATE,DGZIP
- +2 NEW DGCOUNTY,DGPHONE,DGFROMDT,DGTODT,DGPROV,DGPCODE,DGCNTRY,DGFORN
- +3 ;
- +4 SET DGADRACT=$GET(DGARRY(.12105))
- +5 SET DGADR1=$GET(DGARRY(.1211))
- +6 SET DGADR2=$GET(DGARRY(.1212))
- +7 SET DGADR3=$GET(DGARRY(.1213))
- +8 SET DGCITY=$GET(DGARRY(.1214))
- +9 SET DGSTATE=$GET(DGARRY(.1215))
- +10 SET DGZIP=$GET(DGARRY(.1216))
- +11 SET DGCOUNTY=$GET(DGARRY(.12111))
- +12 IF DGCOUNTY'=""
- IF DGSTATE'=""
- IF $DATA(^DIC(5,DGSTATE,1,DGCOUNTY,0))
- Begin DoDot:1
- +13 SET DGCOUNTY=$PIECE(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^")_$SELECT($PIECE(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)'="":"("_$PIECE(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)_")",1:"")
- End DoDot:1
- +14 ;changing to remove display of empty (), will only display if a code is in the 4th piece of the state file-Patch 872
- +15 ;S DGCOUNTY=$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^")_"( "_$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)
- +16 IF DGADRACT'="Y"
- SET DGCOUNTY="NOT APPLICABLE"
- +17 IF DGSTATE'=""
- IF $DATA(^DIC(5,DGSTATE,0))
- SET DGSTATE=$PIECE(^DIC(5,DGSTATE,0),"^",2)
- +18 SET DGPROV=$GET(DGARRY(.1221))
- +19 SET DGPCODE=$GET(DGARRY(.1222))
- +20 SET DGCNTRY=$GET(DGARRY(.1223))
- +21 SET DGFORN=$$FORIEN(DGCNTRY)
- +22 IF DGCNTRY]""
- SET DGCNTRY=$$CNTRYI(DGCNTRY)
- +23 SET DGPHONE=$GET(DGARRY(.1219))
- +24 SET DGFROMDT=$$FMTE^XLFDT($GET(DGARRY(.1217)))
- +25 SET DGTODT=$$FMTE^XLFDT($GET(DGARRY(.1218)))
- +26 ;
- +27 ;jam DG*5.3*925 RM#788099 Add/Edit Residential address - Change field label to Temporary Mailing Address:
- +28 WRITE !!,"Temporary Mailing Address: "
- +29 IF DGADRACT="Y"
- Begin DoDot:1
- +30 if DGADR1'=""
- WRITE !?9,DGADR1
- +31 if DGADR2'=""
- WRITE !?9,DGADR2
- +32 if DGADR3'=""
- WRITE !?9,DGADR3
- +33 IF DGFORN=0
- Begin DoDot:2
- +34 WRITE !?9,$SELECT(DGCITY'="":DGCITY,1:"")_$SELECT(DGCITY'="":",",1:" ")_$SELECT(DGSTATE'="":DGSTATE,1:"")_" "_$SELECT(DGZIP'="":DGZIP,1:"")
- End DoDot:2
- +35 ;I DGFORN W !?8,$S(DGPCODE'="":DGPCODE,1:"")_" "_$S(DGCITY'="":DGCITY,1:"")_$S(DGCITY'="":",",1:" ")_$S(DGPROV'="":DGPROV,1:"") ;DG*1010 comment out
- +36 ;DG*1010 - display postal code last
- IF DGFORN
- WRITE !?8,$SELECT(DGCITY'="":DGCITY,1:"")_$SELECT(DGCITY'="":",",1:" ")_$SELECT(DGPROV'="":DGPROV,1:"")_" "_$SELECT(DGPCODE'="":DGPCODE,1:"")
- End DoDot:1
- +37 ;commenting out, causes address to print 2x. Patch 872
- +38 ;W !?9,$S(DGCITY'="":DGCITY,1:"")_","_$S(DGSTATE'="":DGSTATE,1:"")_" "_$S(DGZIP'="":DGZIP,1:"")
- +39 ;Removing lines from dot structure Patch 872
- +40 WRITE !," County: "_DGCOUNTY
- +41 WRITE !," Phone: "_DGPHONE
- +42 WRITE !,"From/To: "_$PIECE(DGFROMDT,",")_","_$PIECE(DGFROMDT,", ",2)_"-"_$PIECE(DGTODT,",")_","_$PIECE(DGTODT,", ",2)
- +43 ;
- +44 IF $GET(DGARRY(.12105))="N"
- Begin DoDot:1
- +45 if $GET(DGARRY(.1211))=""
- WRITE !?9,"NO TEMPORARY ADDRESS"
- +46 if $GET(DGARRY(.1212))=""
- WRITE !?9,""
- +47 WRITE !," County: NOT APPLICABLE"
- +48 WRITE !," Phone: NOT APPLICABLE"
- +49 WRITE !,"From/To: NOT APPLICABLE"
- End DoDot:1
- +50 QUIT
- COUNTRY(DGC) ;
- +1 ;where DGC is the external value of the country
- +2 ;return value is in upper case display mode
- +3 ;if DGC is invalid, return -1
- +4 NEW DGCC,DGIEN
- +5 ; if input is NULL change to US
- +6 IF $GET(DGC)=""
- SET DGC="USA"
- +7 ; Get IEN from B index, error if not found
- +8 SET DGIEN=$ORDER(^HL(779.004,"B",DGC,""))
- if DGIEN']""
- QUIT -1
- +9 ; xlate IEN to POSTAL NAME
- +10 SET DGCC=$PIECE(^HL(779.004,DGIEN,"SDS"),U,3)
- +11 ; if POSTAL NAME = "<NULL>" return DESCRIPTION
- +12 IF DGCC="<NULL>"
- Begin DoDot:1
- +13 SET DGCC=$$UPPER^DGUTL($PIECE(^HL(779.004,DGIEN,0),U,2))
- End DoDot:1
- +14 QUIT DGCC
- FOR(DGC) ;returns a 1 if address is foreign, a 0 if domestic, -1 if DGC is not valid
- +1 ; DGC is the external value of the country (.01 field of file 779.004)
- +2 NEW DGFOR
- +3 SET DGFOR=0
- +4 IF $GET(DGC)=""
- QUIT DGFOR
- +5 IF '$DATA(^HL(779.004,"B",DGC))
- QUIT -1
- +6 IF DGC'="USA"
- SET DGFOR=1
- +7 QUIT DGFOR
- CNTRYI(DGIEN) ;where DGC is the internal value of the country
- +1 ;return DGC as the display value for the country
- +2 ;if the input value is not a valid IEN, return -1
- +3 ;if the input value is null, return null
- +4 NEW DGCC
- +5 IF $GET(DGIEN)=""
- QUIT ""
- +6 IF '$DATA(^HL(779.004,DGIEN,0))
- QUIT -1
- +7 ; xlate IEN to POSTAL NAME
- +8 SET DGCC=$PIECE(^HL(779.004,DGIEN,"SDS"),U,3)
- +9 ; if POSTAL NAME = "<NULL>" return DESCRIPTION
- +10 IF DGCC="<NULL>"
- Begin DoDot:1
- +11 SET DGCC=$$UPPER^DGUTL($PIECE(^HL(779.004,DGIEN,0),U,2))
- End DoDot:1
- +12 QUIT DGCC
- FORIEN(DGC) ;returns a 1 if address is foreign, a 0 if domestic, -1 if DGC is invalid
- +1 ;DGC is the IEN of the country file (#779.004)
- +2 NEW DGFOR
- +3 SET DGFOR=0
- +4 IF $GET(DGC)=""
- QUIT DGFOR
- +5 IF DGC'?1.3N
- QUIT -1
- +6 IF '$DATA(^HL(779.004,DGC,0))
- QUIT -1
- +7 IF DGC]""
- IF (DGC'=$ORDER(^HL(779.004,"B","USA","")))
- SET DGFOR=1
- +8 QUIT DGFOR