DGRPU ;ALB/MRL,TMK - REGISTRATION UTILITY ROUTINE ;19 OCT 2005
;;5.3;Registration;**33,114,489,624,672,689,1015**;Aug 13, 1993;Build 20
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 W @IOF S Z="ADDITIONAL PATIENT DEMOGRAPHIC DATA, SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
S X=$$SSNNM(DFN)
I '$D(DGRPH) W !,X S X=$S($D(DGRPTYPE):$P(DGRPTYPE,"^",1),1:"PATIENT TYPE UNKNOWN"),X1=79-$L(X) W ?X1,X
S X="",$P(X,"=",80)="" W !,X Q
Q
;
AL(DGLEN) ;DGLEN= Available length of line
A ;Format address(es)
I '$D(DGLEN) N DGLEN S DGLEN=29
N DGX
F I=DGA1:1:DGA1+2 I $P(DGRP(DGAD),U,I)]"" S DGA(DGA2)=$P(DGRP(DGAD),U,I),DGA2=DGA2+2
I DGA2=1 S DGA(1)="STREET ADDRESS UNKNOWN",DGA2=DGA2+2
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),DGA(DGA2)=$S(J(1)]""&(J]""):J(1)_","_J,J(1)]"":J(1),J]"":J,1:"UNK. CITY/STATE")
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
.S DGX=$P(DGRP(DGAD),U,DGA1+11)
S:$L(DGX)>5 DGX=$E(DGX,1,5)_"-"_$E(DGX,6,9)
S DGA(DGA2)=$E($P(DGA(DGA2),",",1),1,(DGLEN-($L(DGX)+4)))_$S($L($P(DGA(DGA2),",",2)):",",1:"")_$P(DGA(DGA2),",",2)_" "_DGX
F I=0:0 S I=$O(DGA(I)) Q:'I S DGA(I)=$E(DGA(I),1,DGLEN)
K DGA1,I,J
Q
;
W I IOST="C-QUME",$L(DGVI)'=2 W ?X,Z Q
W ?X,@DGVI,Z,@DGVO
Q
;
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 and name on first line of screen
N X,SSN
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 X=$P(X,U)_"; "_SSN
Q X
;
DGRPU ;ALB/MRL,TMK - REGISTRATION UTILITY ROUTINE ;19 OCT 2005
+1 ;;5.3;Registration;**33,114,489,624,672,689,1015**;Aug 13, 1993;Build 20
H ;Screen Header
+1 IF DGRPS'=1.1
WRITE @IOF
SET Z=$PIECE($TEXT(H1+DGRPS),";;",2)_", SCREEN <"_DGRPS_">"_$SELECT($DATA(DGRPH):" HELP",1:"")
SET X=79-$LENGTH(Z)\2
DO W
+2 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
+3 SET X=$$SSNNM(DFN)
+4 IF '$DATA(DGRPH)
WRITE !,X
SET X=$SELECT($DATA(DGRPTYPE):$PIECE(DGRPTYPE,"^",1),1:"PATIENT TYPE UNKNOWN")
SET X1=79-$LENGTH(X)
WRITE ?X1,X
+5 SET X=""
SET $PIECE(X,"=",80)=""
WRITE !,X
QUIT
+6 QUIT
+7 ;
AL(DGLEN) ;DGLEN= Available length of line
A ;Format address(es)
+1 IF '$DATA(DGLEN)
NEW DGLEN
SET DGLEN=29
+2 NEW DGX
+3 FOR I=DGA1:1:DGA1+2
IF $PIECE(DGRP(DGAD),U,I)]""
SET DGA(DGA2)=$PIECE(DGRP(DGAD),U,I)
SET DGA2=DGA2+2
+4 IF DGA2=1
SET DGA(1)="STREET ADDRESS UNKNOWN"
SET DGA2=DGA2+2
+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 DGA(DGA2)=$SELECT(J(1)]""&(J]""):J(1)_","_J,J(1)]"":J(1),J]"":J,1:"UNK. CITY/STATE")
+6 IF ".33^.34^.211^.331^.311^.25^.21"[DGAD
Begin DoDot:1
+7 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
+8 IF '$TEST
Begin DoDot:1
+9 IF DGAD=.141
SET DGX=$PIECE(DGRP(.141),U,6)
QUIT
+10 SET DGX=$PIECE(DGRP(DGAD),U,DGA1+11)
End DoDot:1
+11 IF $LENGTH(DGX)>5
SET DGX=$EXTRACT(DGX,1,5)_"-"_$EXTRACT(DGX,6,9)
+12 SET DGA(DGA2)=$EXTRACT($PIECE(DGA(DGA2),",",1),1,(DGLEN-($LENGTH(DGX)+4)))_$SELECT($LENGTH($PIECE(DGA(DGA2),",",2)):",",1:"")_$PIECE(DGA(DGA2),",",2)_" "_DGX
+13 FOR I=0:0
SET I=$ORDER(DGA(I))
IF 'I
QUIT
SET DGA(I)=$EXTRACT(DGA(I),1,DGLEN)
+14 KILL DGA1,I,J
+15 QUIT
+16 ;
W IF IOST="C-QUME"
IF $LENGTH(DGVI)'=2
WRITE ?X,Z
QUIT
+1 WRITE ?X,@DGVI,Z,@DGVO
+2 QUIT
+3 ;
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 and name on first line of screen
+1 NEW X,SSN
+2 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)
+3 SET X=$PIECE(X,U)_"; "_SSN
+4 QUIT X
+5 ;
