DGRPU ;ALB/MRL,TMK,BAJ,DJE,JAM,JAM,ARF - REGISTRATION UTILITY ROUTINE ;12/20/2005 5:37PM
;;5.3;Registration;**33,114,489,624,672,689,688,935,941,997,1014**;Aug 13, 1993;Build 42
;
H ;Screen Header
;I DGRPS'=1.1 W @IOF S Z=$P($T(H1+DGRPS),";;",2)_", SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
I DGRPS'=1.1,DGRPS'?1"11.5" W @IOF S Z=$P($T(H1+DGRPS),";;",2)_", SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W ; LEG; DG*5.3*997; excluded 11.5
I DGRPS=1.1 W @IOF S Z="ADDITIONAL PATIENT DEMOGRAPHIC DATA, SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
;ASF; DG*5.3*997; add 11.5 screen
I DGRPS?1"11.5" W @IOF S Z="ADDITIONAL ELIGIBILITY VERIFICATION DATA, SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
S X=$$SSNNM(DFN)
;ARF - DG*5.3*1014 standardize heading and add DOB and PREFERRED NAME
;I '$D(DGRPH) W !,X S X=$S($D(DGRPTYPE):$P(DGRPTYPE,"^",1),1:"PATIENT TYPE UNKNOWN"),X1=79-$L(X) W ?X1,X
I '$D(DGRPH) D ;DG*5.3*1014 begin
.N DGDOB,DGSSN,DGSSNSTR,DGPREFNM,DGPTYPE,DGNAME,DGMEMID,VADEMO ;DG*5.3*1014 - ARF - updating banner with standard patient data
.D DEMUPD^VADPT
.S DGNAME=VADEMO(1)
.S DGPREFNM=$S(VADEMO(1,1)'="":"("_VADEMO(1,1)_")",1:"")
.S DGDOB=$P(VADEMO(3),U,2)
.S DGSSN=$P(VADEMO(2),U,2)
.S DGSSNSTR=$$SSNNM^DGRPU(DFN)
.S DGPTYPE=$$GET1^DIQ(391,$$GET1^DIQ(2,DFN_",",391,"I")_",",.01)
.S:DGPTYPE="" DGPTYPE="PATIENT TYPE UNKNOWN"
.S DGMEMID=$S($P($P(DGSSNSTR,";",2)," ",2)'="":$E($P($P(DGSSNSTR,";",2)," ",2),1,40)_" ",1:"")
.W !,DGNAME W:DGPREFNM'="" " "_DGPREFNM W " "_DGDOB
.W ! W:DGMEMID'="" DGMEMID W DGSSN_" "_DGPTYPE ;DG*5.3*1014 end
S X="",$P(X,"=",80)="" W !,X Q
Q
LISTHDR(DGFIRST) ;sets patient data for banners of list manager screens - DG*5.3*1014
;DGFIRST - Is the first subscript of VALMHDR array where the patient data should
; be stored. This value is increased for the second line of patient data
; VALMHDR(DGFIRST)="NAME (PREFERRED NAME) MON DD, YYYY" note: the date is the DOB
; VALMHDR(DGFIRST+1)="EDI/PI ###-##-#### PATIENT TYPE" note: if there isn't a EDP/PI(member ID) the
; SSN (###-##-####) begins in the first column
N DGSSNSTR,DGPTYPE,DGSSN,DGDOB
S:+DGFIRST=0 DGFIRST=1
S DGSSNSTR=$$SSNNM^DGRPU(DFN)
S DGSSN=$P($P(DGSSNSTR,";",2)," ",3)
S DGDOB=$$GET1^DIQ(2,DFN,.03,"I")
S DGDOB=$$UP^XLFSTR($$FMTE^XLFDT($E(DGDOB,1,12),1))
S DGPTYPE=$$GET1^DIQ(391,$$GET1^DIQ(2,DFN_",",391,"I")_",",.01)
S:DGPTYPE="" DGPTYPE="PATIENT TYPE UNKNOWN"
S VALMHDR(DGFIRST)=$P(DGSSNSTR,";",1)_$S($$GET1^DIQ(2,DFN,.2405)'="":" ("_$$GET1^DIQ(2,DFN,.2405)_")",1:"")_" "_DGDOB
S VALMHDR(DGFIRST+1)=$S($P($P(DGSSNSTR,";",2)," ",2)'="":$E($P($P(DGSSNSTR,";",2)," ",2),1,40)_" ",1:"")_DGSSN_" "_DGPTYPE
Q
AL(DGLEN) ;DGLEN= Available length of line
A ;Format address(es)
; DG*5.3*688 BAJ 12/20/2005 modified for foreign address
I '$D(DGLEN) N DGLEN S DGLEN=29
N I,DGX,FILE,IEN,CNTRY,TMP,FNODE,FPCE,ROU
; set up variables
; jam; DG*5.3*997; foreign address code for NOK/e-contact addresses .21, .211, .33, .331, .34 - country code is in piece 12
;S FNODE=$S(DGAD=.121:.122,1:DGAD),FPCE=$S(DGAD=.121:3,DGAD=.141:16,1:10)
S FNODE=$S(DGAD=.121:.122,1:DGAD),FPCE=$S(DGAD=.121:3,DGAD=.141:16,DGAD=.21:12,DGAD=.211:12,DGAD=.33:12,DGAD=.331:12,DGAD=.34:12,1:10)
; collect Street Address info
F I=DGA1:1:DGA1+2 I $P(DGRP(DGAD),U,I)]"" S TMP(DGA2)=$P(DGRP(DGAD),U,I),DGA2=DGA2+2
I DGA2=1 S TMP(1)="STREET ADDRESS UNKNOWN",DGA2=DGA2+2
; retrieve country info -- PERM country is piece 10 of node .11
S FOR=0
; jam; DG*5.3*997; add the country retrieval for screen 3 - NOK/e-contact/designee addresses
;I DGA1=1 D
I DGA1=1!(DGAD=.21)!(DGAD=.211)!(DGAD=.33)!(DGAD=.331)!(DGAD=.34) D
. ; JAM; DG*5.3*997 - in the $E below, change the length of the CNTRY from 25 chars to DGLEN chars
. S FILE=779.004,IEN=$P(DGRP(FNODE),U,FPCE),CNTRY=$E($$CNTRYI^DGADDUTL(IEN),1,DGLEN) I CNTRY=-1 S CNTRY="UNKNOWN COUNTRY"
. ; assemble (US) CITY, STATE ZIP or (FOREIGN) CITY PROVINCE POSTAL CODE
. S FOR=$$FORIEN^DGADDUTL(IEN) I FOR=-1 S FOR=1
S ROU=$S(FOR=1:"FOREIGN",1:"US")_"(DGAD,.TMP,DGA1,.DGA2)" D @ROU
; append COUNTRY to address
S DGA2=DGA2+2,TMP(DGA2)=$S($G(CNTRY)="":"",1:CNTRY)
M DGA=TMP
K DGA1
Q
;
US(DGAD,TMP,DGA1,DGA2) ;process US addresses and format in DGA array
; DG*5.3*688 BAJ this is the code for all addresses prior to the addition of Foreign address logic.
; Modifications for Foreign address are in Tag FOREIGN
N DGX,I,J
; format STATE field and merge with CITY & ZIP
S J=$S('$D(^DIC(5,+$P(DGRP(DGAD),U,DGA1+4),0)):"",('$L($P(^(0),U,2))):$P(^(0),U,1),1:$P(^(0),U,2)),J(1)=$P(DGRP(DGAD),U,DGA1+3),J(2)=$P(DGRP(DGAD),U,DGA1+5),TMP(DGA2)=$S(J(1)]""&(J]""):J(1)_","_J,J(1)]"":J(1),J]"":J,1:"UNK. CITY/STATE")
; zip code capture
I ".33^.34^.211^.331^.311^.25^.21"[DGAD D
.F I=1:1:7 I $P(".33^.34^.211^.331^.311^.25^.21",U,I)=DGAD S DGX=$P($G(^DPT(DFN,.22)),U,I)
E D
.I DGAD=.141 S DGX=$P(DGRP(.141),U,6) Q
.; JAM - Patch DG*5.3*941, Residential address, zip code is piece 6
.I DGAD=.115 S DGX=$P(DGRP(.115),U,6) Q
.S DGX=$P(DGRP(DGAD),U,DGA1+11)
; format ZIP+4 with hyphen
S:$L(DGX)>5 DGX=$E(DGX,1,5)_"-"_$E(DGX,6,9)
;combine CITY,STATE and ZIP fields on a single line
S TMP(DGA2)=$E($P(TMP(DGA2),",",1),1,(DGLEN-($L(DGX)+4)))_$S($L($P(TMP(DGA2),",",2)):",",1:"")_$P(TMP(DGA2),",",2)_" "_DGX
F I=0:0 S I=$O(TMP(I)) Q:'I S TMP(I)=$E(TMP(I),1,DGLEN)
Q
;
FOREIGN(DGAD,TMP,DGA1,DGA2) ;process FOREIGN addresses and format in DGA array
N I,J,CITY,PRVNCE,PSTCD,FNODE
F I=1:1 S J=$P($T(FNPCS+I),";;",3) Q:J="QUIT" D
. I DGAD=$P(J,";",1) S FNODE=$P(J,";",2),CITY=$P(J,";",3),PRVNCE=$P(J,";",4),PSTCD=$P(J,";",5)
; Assemble CITY PROVINCE and POSTAL CODE on the same line
; NOTE CITY is sometimes on a different node than the PROVINCE & POSTAL CODE
; DG*5.3*997; jam; For screen 3 put Province and Postal Code to a separate line
; - for other screens, rearrange output so City is followed by Province and then Postal code
I $G(DGRPS)=3 D
. S TMP(DGA2)=$P(DGRP(DGAD),U,CITY)
. S DGA2=DGA2+2 S TMP(DGA2)=$P(DGRP(FNODE),U,PRVNCE)_" "_$P(DGRP(FNODE),U,PSTCD)
E S TMP(DGA2)=$P(DGRP(DGAD),U,CITY)_" "_$P(DGRP(FNODE),U,PRVNCE)_" "_$P(DGRP(FNODE),U,PSTCD)
F I=0:0 S I=$O(TMP(I)) Q:'I S TMP(I)=$E(TMP(I),1,DGLEN)
Q
;
W I IOST="C-QUME",$L(DGVI)'=2 W ?X,Z Q
W ?X,@DGVI,Z,@DGVO
Q
;
; JAM - Patch DG*5.3*941, Add Residential address type
; JAM - Patch DG*5.3*997, Add NOK/e-contact address types
FNPCS ; Foreign data pieces. Structure-->Description;;Main Node;Data Node;City;Province;Postal code.
;;Permanent;;.11;.11;4;8;9
;;Temporary;;.121;.122;4;1;2
;;Confidential;;.141;.141;4;14;15
;;Residential;;.115;.115;4;8;9
;;NOK;;.21;.21;6;13;14
;;NOK2;;.211;.211;6;13;14
;;E;;.33;.33;6;13;14
;;E2;;.331;.331;6;13;14
;;D;;.34;.34;6;13;14
;;QUIT;;QUIT
;
H1 ;
;;PATIENT DEMOGRAPHIC DATA
;;PATIENT DATA
;;EMERGENCY CONTACT DATA
;;APPLICANT/SPOUSE EMPLOYMENT DATA
;;INSURANCE DATA
;;MILITARY SERVICE DATA
;;ELIGIBILITY STATUS DATA
;;FAMILY DEMOGRAPHIC DATA
;;INCOME SCREENING DATA
;;INELIGIBLE/MISSING DATA
;;ELIGIBILITY VERIFICATION DATA
;;ADMISSION INFORMATION
;;APPLICATION INFORMATION
;;APPOINTMENT INFORMATION
;;SPONSOR DEMOGRAPHIC INFORMATION
;
;
INCOME(DFN,DGDT) ; compute income for veteran...if not in 408.21, pass back file 2 data
; (called by PTF)
;
;
; Input: DFN as IEN of PATIENT file
; DGDT as date to return income as of
;
; Output: total income (computed function)
; (from 408.21 if available...otherwise from file 2)
;
;
N DGDEP,DGINC,DGREL,DGTOT,DGX,I S DGTOT=0
D ALL^DGMTU21(DFN,"V",DGDT,"I")
S DGX=$G(^DGMT(408.21,+$G(DGINC("V")),0)) I DGX]"" F I=8:1:17 S DGTOT=DGTOT+$P(DGX,"^",I)
I DGX']"" S DGTOT=$P($G(^DPT(DFN,.362)),U,20)
Q DGTOT
;
;
MTCOMP(DFN,DGDT) ; is current means test OR COPAY complete?
;
; Input: DFN as IEN of PATIENT file
; DGDT as 'as of' date
;
; Output: 1 if means test/COPAY for year prior to DT passed is complete
; 0 otherwise
; DGMTYPT 1=MT;2=CP;0=NONE
;
N COMP,MT,X,YR
S YR=$$LYR^DGMTSCU1(DGDT),MT=$$LST^DGMTCOU1(DFN,DGDT)
S DGMTYPT=+$P(MT,U,5)
S COMP=1
I DGMTYPT=1 D ;MT
.I $P(MT,"^",4)']""!("^R^N^"[("^"_$P(MT,"^",4)_"^")) S COMP=0
I DGMTYPT=2 D ;CP
.I $P(MT,"^",4)']""!("^I^L^"[("^"_$P(MT,"^",4)_"^")) S COMP=0
S X=+$P(MT,"^",2) I ($E(X,1,3)-1)*10000<YR S COMP=0
Q COMP
;
HLP1010 ;* This is called by the Executable Help for Patient field #1010.159
; (APPOINTMENT REQUEST ON 1010EZ)
W !!," Enter a 'Y' if the veteran applicant has requested an"
W !," appointment with a VA doctor or provider and wants to be"
W !," seen as soon as one becomes available Enter a 'N'"
W !," if the veteran applicant has not requested an appointment."
W !!," This question may ONLY be entered ONCE for the veteran."
W !," The answer to this question CANNOT be changed after the"
W !," initial entry.",!
Q
;
HLPCS ; * This is called by the Executable Help for Income Relation field #.1
Q:X="?"
N DIR,DGRDVAR
W !?8,"Enter in this field a Yes or No to indicate whether the veteran"
W !?8,"contributed any dollar amount to the child's support last calendar"
W !?8,"year. The contributions do not have to be in regular set amounts."
W !?8,"For example, a veteran who paid a child's school tuition or"
W !?8,"medical bills would be contributing to the child's support.",!
W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
Q
;
HLP1823 ;*This is called by the Executable Help for Patient Relation field #.18
N DIR,DGRDVAR
W !?7,"Enter 'Y' if the child is currently 18 to 23 years old and the child"
W !?7,"attended school last calendar year. Enter 'N' if the child is currently"
W !?7,"18 to 23 years old but the child did not attend school last calendar"
W !?7,"year. Enter 'N' if the child is not currently 18 to 23 years old.",!
I $G(DA) W !,"Enter RETURN to continue:" R DGRDVAR:DTIME W !
Q
;
HLPMLDS ;* This is called by the Executable Help for Patient field #.362
; (DISABILITY RET. FROM MILITARY?)
N X,Y,DIR
W !!," Enter '0' or 'NO' if the veteran:"
W !," -- Is NOT retired from the military OR"
W !," -- Is retired from the military due to length of service AND"
W !," does NOT have a disability confirmed by the Military Branch"
W !," to have been incurred in or aggravated while on active duty."
W !!," Enter '1' or 'YES, RECEIVING MILITARY RETIREMENT' if the veteran:"
W !," -- Is confirmed by the Military Branch to have been discharged"
W !," or released due to a disability incurred in or aggravated"
W !," while on active duty AND"
W !," -- Has NOT filed a claim for VA compensation benefits OR"
W !," -- Has been rated by the VA to be NSC OR"
W !," -- Has been rated by the VA to have noncompensable 0%"
W !," SC conditions."
S DIR(0)="E" D ^DIR Q:+Y<1
W !!," Enter '2' or 'YES, RECEIVING MILITARY RETIREMENT IN LIEU OF VA"
W !," COMPENSATION' if the veteran:"
W !," -- Is confirmed by the Military Branch to have been discharged"
W !," or released due to a disability incurred in or aggravated"
W !," while on active duty AND"
W !," -- Is receiving military disability retirement pay AND"
W !," -- Has been rated by VA to have compensable SC conditions"
W !," but is NOT receiving compensation from the VA"
W !!," Once eligibility has been verified, this field will no longer"
W !," be editable to any user who does not hold the designated security"
W !," key."
Q
HLP3602 ;help text for field .3602, Rec'ing Disability in Lieu of VA Comp
W !," Enter 'Y' if this veteran applicant is receiving disability"
W !," retirement pay from the Military instead of VA compensation."
W !," Enter 'N' if this veteran applicant is not receiving disability"
W !," retirement pay from the Military instead of VA compensation."
W !," Once eligibility has been verified by HEC this field will no longer "
W !," be editable by VistA users. Send updates and/or requests to HEC."
Q
HLP3603 ;help text for field .3603, Discharge Due to LOD Disability
W !," Enter 'Y' if this veteran applicant was discharged from the"
W !," military for a disability incurred or aggravated in the line "
W !," of duty. Enter 'N' if this veteran applicant was not discharged"
W !," from the military for a disability incurred or aggravated in the"
W !," line of duty. Once eligibility has been verified by HEC this field"
W !," will no longer be editable by VistA users. Send updates and/or requests"
W !," to HEC."
Q
SSNNM(DFN) ; SSN, EDIPI and name on first line of screen
;DJE - DG*5.3*935 - Add Member ID To Vista Registration Banner
N X,SSN,EDIPI,IDSTAT,J,ASFC,LIST,PT,STK
S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
;
S PT=DFN_"^PI^USVHA^"_$P($$SITE^VASITE(),U,3)
D TFL^VAFCTFU2(.LIST,PT)
S EDIPI="",IDSTAT="",J=1
S STK="" F S STK=$O(LIST(STK)) D Q:STK=""
.Q:STK=""
.S ASFC=$P(LIST(STK),U,3)
.Q:ASFC'="USDOD"
.S IDSTAT=$P(LIST(STK),U,5)
.S EDIPI=$P(LIST(STK),U,1)
.I (IDSTAT="A"),(EDIPI>1) S STK="" Q ;First active EDIPI
.I IDSTAT="H" S EDIPI(J)=EDIPI S J=J+1
.S EDIPI=""
I IDSTAT="H" S EDIPI=EDIPI(1) ; First inactive EDIPI
S X=$P(X,U)_"; "_EDIPI_" "_SSN
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPU 13518 printed Sep 23, 2025@20:33:02 Page 2
DGRPU ;ALB/MRL,TMK,BAJ,DJE,JAM,JAM,ARF - REGISTRATION UTILITY ROUTINE ;12/20/2005 5:37PM
+1 ;;5.3;Registration;**33,114,489,624,672,689,688,935,941,997,1014**;Aug 13, 1993;Build 42
+2 ;
H ;Screen Header
+1 ;I DGRPS'=1.1 W @IOF S Z=$P($T(H1+DGRPS),";;",2)_", SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
+2 ; LEG; DG*5.3*997; excluded 11.5
IF DGRPS'=1.1
IF DGRPS'?1"11.5"
WRITE @IOF
SET Z=$PIECE($TEXT(H1+DGRPS),";;",2)_", SCREEN <"_DGRPS_">"_$SELECT($DATA(DGRPH):" HELP",1:"")
SET X=79-$LENGTH(Z)\2
DO W
+3 IF DGRPS=1.1
WRITE @IOF
SET Z="ADDITIONAL PATIENT DEMOGRAPHIC DATA, SCREEN <"_DGRPS_">"_$SELECT($DATA(DGRPH):" HELP",1:"")
SET X=79-$LENGTH(Z)\2
DO W
+4 ;ASF; DG*5.3*997; add 11.5 screen
+5 IF DGRPS?1"11.5"
WRITE @IOF
SET Z="ADDITIONAL ELIGIBILITY VERIFICATION DATA, SCREEN <"_DGRPS_">"_$SELECT($DATA(DGRPH):" HELP",1:"")
SET X=79-$LENGTH(Z)\2
DO W
+6 SET X=$$SSNNM(DFN)
+7 ;ARF - DG*5.3*1014 standardize heading and add DOB and PREFERRED NAME
+8 ;I '$D(DGRPH) W !,X S X=$S($D(DGRPTYPE):$P(DGRPTYPE,"^",1),1:"PATIENT TYPE UNKNOWN"),X1=79-$L(X) W ?X1,X
+9 ;DG*5.3*1014 begin
IF '$DATA(DGRPH)
Begin DoDot:1
+10 ;DG*5.3*1014 - ARF - updating banner with standard patient data
NEW DGDOB,DGSSN,DGSSNSTR,DGPREFNM,DGPTYPE,DGNAME,DGMEMID,VADEMO
+11 DO DEMUPD^VADPT
+12 SET DGNAME=VADEMO(1)
+13 SET DGPREFNM=$SELECT(VADEMO(1,1)'="":"("_VADEMO(1,1)_")",1:"")
+14 SET DGDOB=$PIECE(VADEMO(3),U,2)
+15 SET DGSSN=$PIECE(VADEMO(2),U,2)
+16 SET DGSSNSTR=$$SSNNM^DGRPU(DFN)
+17 SET DGPTYPE=$$GET1^DIQ(391,$$GET1^DIQ(2,DFN_",",391,"I")_",",.01)
+18 if DGPTYPE=""
SET DGPTYPE="PATIENT TYPE UNKNOWN"
+19 SET DGMEMID=$SELECT($PIECE($PIECE(DGSSNSTR,";",2)," ",2)'="":$EXTRACT($PIECE($PIECE(DGSSNSTR,";",2)," ",2),1,40)_" ",1:"")
+20 WRITE !,DGNAME
if DGPREFNM'=""
WRITE " "_DGPREFNM
WRITE " "_DGDOB
+21 ;DG*5.3*1014 end
WRITE !
if DGMEMID'=""
WRITE DGMEMID
WRITE DGSSN_" "_DGPTYPE
End DoDot:1
+22 SET X=""
SET $PIECE(X,"=",80)=""
WRITE !,X
QUIT
+23 QUIT
LISTHDR(DGFIRST) ;sets patient data for banners of list manager screens - DG*5.3*1014
+1 ;DGFIRST - Is the first subscript of VALMHDR array where the patient data should
+2 ; be stored. This value is increased for the second line of patient data
+3 ; VALMHDR(DGFIRST)="NAME (PREFERRED NAME) MON DD, YYYY" note: the date is the DOB
+4 ; VALMHDR(DGFIRST+1)="EDI/PI ###-##-#### PATIENT TYPE" note: if there isn't a EDP/PI(member ID) the
+5 ; SSN (###-##-####) begins in the first column
+6 NEW DGSSNSTR,DGPTYPE,DGSSN,DGDOB
+7 if +DGFIRST=0
SET DGFIRST=1
+8 SET DGSSNSTR=$$SSNNM^DGRPU(DFN)
+9 SET DGSSN=$PIECE($PIECE(DGSSNSTR,";",2)," ",3)
+10 SET DGDOB=$$GET1^DIQ(2,DFN,.03,"I")
+11 SET DGDOB=$$UP^XLFSTR($$FMTE^XLFDT($EXTRACT(DGDOB,1,12),1))
+12 SET DGPTYPE=$$GET1^DIQ(391,$$GET1^DIQ(2,DFN_",",391,"I")_",",.01)
+13 if DGPTYPE=""
SET DGPTYPE="PATIENT TYPE UNKNOWN"
+14 SET VALMHDR(DGFIRST)=$PIECE(DGSSNSTR,";",1)_$SELECT($$GET1^DIQ(2,DFN,.2405)'="":" ("_$$GET1^DIQ(2,DFN,.2405)_")",1:"")_" "_DGDOB
+15 SET VALMHDR(DGFIRST+1)=$SELECT($PIECE($PIECE(DGSSNSTR,";",2)," ",2)'="":$EXTRACT($PIECE($PIECE(DGSSNSTR,";",2)," ",2),1,40)_" ",1:"")_DGSSN_" "_DGPTYPE
+16 QUIT
AL(DGLEN) ;DGLEN= Available length of line
A ;Format address(es)
+1 ; DG*5.3*688 BAJ 12/20/2005 modified for foreign address
+2 IF '$DATA(DGLEN)
NEW DGLEN
SET DGLEN=29
+3 NEW I,DGX,FILE,IEN,CNTRY,TMP,FNODE,FPCE,ROU
+4 ; set up variables
+5 ; jam; DG*5.3*997; foreign address code for NOK/e-contact addresses .21, .211, .33, .331, .34 - country code is in piece 12
+6 ;S FNODE=$S(DGAD=.121:.122,1:DGAD),FPCE=$S(DGAD=.121:3,DGAD=.141:16,1:10)
+7 SET FNODE=$SELECT(DGAD=.121:.122,1:DGAD)
SET FPCE=$SELECT(DGAD=.121:3,DGAD=.141:16,DGAD=.21:12,DGAD=.211:12,DGAD=.33:12,DGAD=.331:12,DGAD=.34:12,1:10)
+8 ; collect Street Address info
+9 FOR I=DGA1:1:DGA1+2
IF $PIECE(DGRP(DGAD),U,I)]""
SET TMP(DGA2)=$PIECE(DGRP(DGAD),U,I)
SET DGA2=DGA2+2
+10 IF DGA2=1
SET TMP(1)="STREET ADDRESS UNKNOWN"
SET DGA2=DGA2+2
+11 ; retrieve country info -- PERM country is piece 10 of node .11
+12 SET FOR=0
+13 ; jam; DG*5.3*997; add the country retrieval for screen 3 - NOK/e-contact/designee addresses
+14 ;I DGA1=1 D
+15 IF DGA1=1!(DGAD=.21)!(DGAD=.211)!(DGAD=.33)!(DGAD=.331)!(DGAD=.34)
Begin DoDot:1
+16 ; JAM; DG*5.3*997 - in the $E below, change the length of the CNTRY from 25 chars to DGLEN chars
+17 SET FILE=779.004
SET IEN=$PIECE(DGRP(FNODE),U,FPCE)
SET CNTRY=$EXTRACT($$CNTRYI^DGADDUTL(IEN),1,DGLEN)
IF CNTRY=-1
SET CNTRY="UNKNOWN COUNTRY"
+18 ; assemble (US) CITY, STATE ZIP or (FOREIGN) CITY PROVINCE POSTAL CODE
+19 SET FOR=$$FORIEN^DGADDUTL(IEN)
IF FOR=-1
SET FOR=1
End DoDot:1
+20 SET ROU=$SELECT(FOR=1:"FOREIGN",1:"US")_"(DGAD,.TMP,DGA1,.DGA2)"
DO @ROU
+21 ; append COUNTRY to address
+22 SET DGA2=DGA2+2
SET TMP(DGA2)=$SELECT($GET(CNTRY)="":"",1:CNTRY)
+23 MERGE DGA=TMP
+24 KILL DGA1
+25 QUIT
+26 ;
US(DGAD,TMP,DGA1,DGA2) ;process US addresses and format in DGA array
+1 ; DG*5.3*688 BAJ this is the code for all addresses prior to the addition of Foreign address logic.
+2 ; Modifications for Foreign address are in Tag FOREIGN
+3 NEW DGX,I,J
+4 ; format STATE field and merge with CITY & ZIP
+5 SET J=$SELECT('$DATA(^DIC(5,+$PIECE(DGRP(DGAD),U,DGA1+4),0)):"",('$LENGTH($PIECE(^(0),U,2))):$PIECE(^(0),U,1),1:$PIECE(^(0),U,2))
SET J(1)=$PIECE(DGRP(DGAD),U,DGA1+3)
SET J(2)=$PIECE(DGRP(DGAD),U,DGA1+5)
SET TMP(DGA2)=$SELECT(J(1)]""&(J]""):J(1)_","_J,J(1)]"":J(1),J]"":J,1:"UNK. CITY/STATE")
+6 ; zip code capture
+7 IF ".33^.34^.211^.331^.311^.25^.21"[DGAD
Begin DoDot:1
+8 FOR I=1:1:7
IF $PIECE(".33^.34^.211^.331^.311^.25^.21",U,I)=DGAD
SET DGX=$PIECE($GET(^DPT(DFN,.22)),U,I)
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 IF DGAD=.141
SET DGX=$PIECE(DGRP(.141),U,6)
QUIT
+11 ; JAM - Patch DG*5.3*941, Residential address, zip code is piece 6
+12 IF DGAD=.115
SET DGX=$PIECE(DGRP(.115),U,6)
QUIT
+13 SET DGX=$PIECE(DGRP(DGAD),U,DGA1+11)
End DoDot:1
+14 ; format ZIP+4 with hyphen
+15 if $LENGTH(DGX)>5
SET DGX=$EXTRACT(DGX,1,5)_"-"_$EXTRACT(DGX,6,9)
+16 ;combine CITY,STATE and ZIP fields on a single line
+17 SET TMP(DGA2)=$EXTRACT($PIECE(TMP(DGA2),",",1),1,(DGLEN-($LENGTH(DGX)+4)))_$SELECT($LENGTH($PIECE(TMP(DGA2),",",2)):",",1:"")_$PIECE(TMP(DGA2),",",2)_" "_DGX
+18 FOR I=0:0
SET I=$ORDER(TMP(I))
if 'I
QUIT
SET TMP(I)=$EXTRACT(TMP(I),1,DGLEN)
+19 QUIT
+20 ;
FOREIGN(DGAD,TMP,DGA1,DGA2) ;process FOREIGN addresses and format in DGA array
+1 NEW I,J,CITY,PRVNCE,PSTCD,FNODE
+2 FOR I=1:1
SET J=$PIECE($TEXT(FNPCS+I),";;",3)
if J="QUIT"
QUIT
Begin DoDot:1
+3 IF DGAD=$PIECE(J,";",1)
SET FNODE=$PIECE(J,";",2)
SET CITY=$PIECE(J,";",3)
SET PRVNCE=$PIECE(J,";",4)
SET PSTCD=$PIECE(J,";",5)
End DoDot:1
+4 ; Assemble CITY PROVINCE and POSTAL CODE on the same line
+5 ; NOTE CITY is sometimes on a different node than the PROVINCE & POSTAL CODE
+6 ; DG*5.3*997; jam; For screen 3 put Province and Postal Code to a separate line
+7 ; - for other screens, rearrange output so City is followed by Province and then Postal code
+8 IF $GET(DGRPS)=3
Begin DoDot:1
+9 SET TMP(DGA2)=$PIECE(DGRP(DGAD),U,CITY)
+10 SET DGA2=DGA2+2
SET TMP(DGA2)=$PIECE(DGRP(FNODE),U,PRVNCE)_" "_$PIECE(DGRP(FNODE),U,PSTCD)
End DoDot:1
+11 IF '$TEST
SET TMP(DGA2)=$PIECE(DGRP(DGAD),U,CITY)_" "_$PIECE(DGRP(FNODE),U,PRVNCE)_" "_$PIECE(DGRP(FNODE),U,PSTCD)
+12 FOR I=0:0
SET I=$ORDER(TMP(I))
if 'I
QUIT
SET TMP(I)=$EXTRACT(TMP(I),1,DGLEN)
+13 QUIT
+14 ;
W IF IOST="C-QUME"
IF $LENGTH(DGVI)'=2
WRITE ?X,Z
QUIT
+1 WRITE ?X,@DGVI,Z,@DGVO
+2 QUIT
+3 ;
+4 ; JAM - Patch DG*5.3*941, Add Residential address type
+5 ; JAM - Patch DG*5.3*997, Add NOK/e-contact address types
FNPCS ; Foreign data pieces. Structure-->Description;;Main Node;Data Node;City;Province;Postal code.
+1 ;;Permanent;;.11;.11;4;8;9
+2 ;;Temporary;;.121;.122;4;1;2
+3 ;;Confidential;;.141;.141;4;14;15
+4 ;;Residential;;.115;.115;4;8;9
+5 ;;NOK;;.21;.21;6;13;14
+6 ;;NOK2;;.211;.211;6;13;14
+7 ;;E;;.33;.33;6;13;14
+8 ;;E2;;.331;.331;6;13;14
+9 ;;D;;.34;.34;6;13;14
+10 ;;QUIT;;QUIT
+11 ;
H1 ;
+1 ;;PATIENT DEMOGRAPHIC DATA
+2 ;;PATIENT DATA
+3 ;;EMERGENCY CONTACT DATA
+4 ;;APPLICANT/SPOUSE EMPLOYMENT DATA
+5 ;;INSURANCE DATA
+6 ;;MILITARY SERVICE DATA
+7 ;;ELIGIBILITY STATUS DATA
+8 ;;FAMILY DEMOGRAPHIC DATA
+9 ;;INCOME SCREENING DATA
+10 ;;INELIGIBLE/MISSING DATA
+11 ;;ELIGIBILITY VERIFICATION DATA
+12 ;;ADMISSION INFORMATION
+13 ;;APPLICATION INFORMATION
+14 ;;APPOINTMENT INFORMATION
+15 ;;SPONSOR DEMOGRAPHIC INFORMATION
+16 ;
+17 ;
INCOME(DFN,DGDT) ; compute income for veteran...if not in 408.21, pass back file 2 data
+1 ; (called by PTF)
+2 ;
+3 ;
+4 ; Input: DFN as IEN of PATIENT file
+5 ; DGDT as date to return income as of
+6 ;
+7 ; Output: total income (computed function)
+8 ; (from 408.21 if available...otherwise from file 2)
+9 ;
+10 ;
+11 NEW DGDEP,DGINC,DGREL,DGTOT,DGX,I
SET DGTOT=0
+12 DO ALL^DGMTU21(DFN,"V",DGDT,"I")
+13 SET DGX=$GET(^DGMT(408.21,+$GET(DGINC("V")),0))
IF DGX]""
FOR I=8:1:17
SET DGTOT=DGTOT+$PIECE(DGX,"^",I)
+14 IF DGX']""
SET DGTOT=$PIECE($GET(^DPT(DFN,.362)),U,20)
+15 QUIT DGTOT
+16 ;
+17 ;
MTCOMP(DFN,DGDT) ; is current means test OR COPAY complete?
+1 ;
+2 ; Input: DFN as IEN of PATIENT file
+3 ; DGDT as 'as of' date
+4 ;
+5 ; Output: 1 if means test/COPAY for year prior to DT passed is complete
+6 ; 0 otherwise
+7 ; DGMTYPT 1=MT;2=CP;0=NONE
+8 ;
+9 NEW COMP,MT,X,YR
+10 SET YR=$$LYR^DGMTSCU1(DGDT)
SET MT=$$LST^DGMTCOU1(DFN,DGDT)
+11 SET DGMTYPT=+$PIECE(MT,U,5)
+12 SET COMP=1
+13 ;MT
IF DGMTYPT=1
Begin DoDot:1
+14 IF $PIECE(MT,"^",4)']""!("^R^N^"[("^"_$PIECE(MT,"^",4)_"^"))
SET COMP=0
End DoDot:1
+15 ;CP
IF DGMTYPT=2
Begin DoDot:1
+16 IF $PIECE(MT,"^",4)']""!("^I^L^"[("^"_$PIECE(MT,"^",4)_"^"))
SET COMP=0
End DoDot:1
+17 SET X=+$PIECE(MT,"^",2)
IF ($EXTRACT(X,1,3)-1)*10000<YR
SET COMP=0
+18 QUIT COMP
+19 ;
HLP1010 ;* This is called by the Executable Help for Patient field #1010.159
+1 ; (APPOINTMENT REQUEST ON 1010EZ)
+2 WRITE !!," Enter a 'Y' if the veteran applicant has requested an"
+3 WRITE !," appointment with a VA doctor or provider and wants to be"
+4 WRITE !," seen as soon as one becomes available Enter a 'N'"
+5 WRITE !," if the veteran applicant has not requested an appointment."
+6 WRITE !!," This question may ONLY be entered ONCE for the veteran."
+7 WRITE !," The answer to this question CANNOT be changed after the"
+8 WRITE !," initial entry.",!
+9 QUIT
+10 ;
HLPCS ; * This is called by the Executable Help for Income Relation field #.1
+1 if X="?"
QUIT
+2 NEW DIR,DGRDVAR
+3 WRITE !?8,"Enter in this field a Yes or No to indicate whether the veteran"
+4 WRITE !?8,"contributed any dollar amount to the child's support last calendar"
+5 WRITE !?8,"year. The contributions do not have to be in regular set amounts."
+6 WRITE !?8,"For example, a veteran who paid a child's school tuition or"
+7 WRITE !?8,"medical bills would be contributing to the child's support.",!
+8 WRITE !,"Enter RETURN to continue:"
READ DGRDVAR:DTIME
WRITE !
+9 QUIT
+10 ;
HLP1823 ;*This is called by the Executable Help for Patient Relation field #.18
+1 NEW DIR,DGRDVAR
+2 WRITE !?7,"Enter 'Y' if the child is currently 18 to 23 years old and the child"
+3 WRITE !?7,"attended school last calendar year. Enter 'N' if the child is currently"
+4 WRITE !?7,"18 to 23 years old but the child did not attend school last calendar"
+5 WRITE !?7,"year. Enter 'N' if the child is not currently 18 to 23 years old.",!
+6 IF $GET(DA)
WRITE !,"Enter RETURN to continue:"
READ DGRDVAR:DTIME
WRITE !
+7 QUIT
+8 ;
HLPMLDS ;* This is called by the Executable Help for Patient field #.362
+1 ; (DISABILITY RET. FROM MILITARY?)
+2 NEW X,Y,DIR
+3 WRITE !!," Enter '0' or 'NO' if the veteran:"
+4 WRITE !," -- Is NOT retired from the military OR"
+5 WRITE !," -- Is retired from the military due to length of service AND"
+6 WRITE !," does NOT have a disability confirmed by the Military Branch"
+7 WRITE !," to have been incurred in or aggravated while on active duty."
+8 WRITE !!," Enter '1' or 'YES, RECEIVING MILITARY RETIREMENT' if the veteran:"
+9 WRITE !," -- Is confirmed by the Military Branch to have been discharged"
+10 WRITE !," or released due to a disability incurred in or aggravated"
+11 WRITE !," while on active duty AND"
+12 WRITE !," -- Has NOT filed a claim for VA compensation benefits OR"
+13 WRITE !," -- Has been rated by the VA to be NSC OR"
+14 WRITE !," -- Has been rated by the VA to have noncompensable 0%"
+15 WRITE !," SC conditions."
+16 SET DIR(0)="E"
DO ^DIR
if +Y<1
QUIT
+17 WRITE !!," Enter '2' or 'YES, RECEIVING MILITARY RETIREMENT IN LIEU OF VA"
+18 WRITE !," COMPENSATION' if the veteran:"
+19 WRITE !," -- Is confirmed by the Military Branch to have been discharged"
+20 WRITE !," or released due to a disability incurred in or aggravated"
+21 WRITE !," while on active duty AND"
+22 WRITE !," -- Is receiving military disability retirement pay AND"
+23 WRITE !," -- Has been rated by VA to have compensable SC conditions"
+24 WRITE !," but is NOT receiving compensation from the VA"
+25 WRITE !!," Once eligibility has been verified, this field will no longer"
+26 WRITE !," be editable to any user who does not hold the designated security"
+27 WRITE !," key."
+28 QUIT
HLP3602 ;help text for field .3602, Rec'ing Disability in Lieu of VA Comp
+1 WRITE !," Enter 'Y' if this veteran applicant is receiving disability"
+2 WRITE !," retirement pay from the Military instead of VA compensation."
+3 WRITE !," Enter 'N' if this veteran applicant is not receiving disability"
+4 WRITE !," retirement pay from the Military instead of VA compensation."
+5 WRITE !," Once eligibility has been verified by HEC this field will no longer "
+6 WRITE !," be editable by VistA users. Send updates and/or requests to HEC."
+7 QUIT
HLP3603 ;help text for field .3603, Discharge Due to LOD Disability
+1 WRITE !," Enter 'Y' if this veteran applicant was discharged from the"
+2 WRITE !," military for a disability incurred or aggravated in the line "
+3 WRITE !," of duty. Enter 'N' if this veteran applicant was not discharged"
+4 WRITE !," from the military for a disability incurred or aggravated in the"
+5 WRITE !," line of duty. Once eligibility has been verified by HEC this field"
+6 WRITE !," will no longer be editable by VistA users. Send updates and/or requests"
+7 WRITE !," to HEC."
+8 QUIT
SSNNM(DFN) ; SSN, EDIPI and name on first line of screen
+1 ;DJE - DG*5.3*935 - Add Member ID To Vista Registration Banner
+2 NEW X,SSN,EDIPI,IDSTAT,J,ASFC,LIST,PT,STK
+3 SET X=$SELECT($DATA(^DPT(+DFN,0)):^(0),1:"")
SET SSN=$PIECE(X,"^",9)
SET SSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,10)
+4 ;
+5 SET PT=DFN_"^PI^USVHA^"_$PIECE($$SITE^VASITE(),U,3)
+6 DO TFL^VAFCTFU2(.LIST,PT)
+7 SET EDIPI=""
SET IDSTAT=""
SET J=1
+8 SET STK=""
FOR
SET STK=$ORDER(LIST(STK))
Begin DoDot:1
+9 if STK=""
QUIT
+10 SET ASFC=$PIECE(LIST(STK),U,3)
+11 if ASFC'="USDOD"
QUIT
+12 SET IDSTAT=$PIECE(LIST(STK),U,5)
+13 SET EDIPI=$PIECE(LIST(STK),U,1)
+14 ;First active EDIPI
IF (IDSTAT="A")
IF (EDIPI>1)
SET STK=""
QUIT
+15 IF IDSTAT="H"
SET EDIPI(J)=EDIPI
SET J=J+1
+16 SET EDIPI=""
End DoDot:1
if STK=""
QUIT
+17 ; First inactive EDIPI
IF IDSTAT="H"
SET EDIPI=EDIPI(1)
+18 SET X=$PIECE(X,U)_"; "_EDIPI_" "_SSN
+19 QUIT X
