- DVBHQM1 ;ISC-ALBANY/PKE/JLU - create mail message;8/27/05 4:18pm
- ;;4.0;HINQ;**49,65**;03/25/92;Build 19
- G EN
- LIN Q:CT>200 S CT=CT+1,A1=A_CT_",0)",@A1=T1 Q
- DD S:Y Y=$S($E(Y,4,5):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(Y,4,5))_" ",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_",",1:"")_($E(Y,1,3)+1700)_$P("@"_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),"^",Y[".") S:$L(Y)=10 Y=Y_" " Q
- ;
- EN S DVBCTN=CT+1
- I $D(DVBNAME),DVBNAME'?7" " S T1=" VBA name = "_DVBNAME D LIN
- I $D(DVBPNAM) S T1=" Prior names =" D LIN S T1="" F I=0:0 S I=$O(DVBPNAM(I)) Q:I="" D
- . S T1=" "_DVBPNAM(I)
- . D LIN
- ;I $D(DVBPNAM) D LIN
- I $D(DVBADRLN),+DVBADRLN F G=1:1:$S(DVBADRLN<7:DVBADRLN,1:0) I $D(DVBADR(G)) S CT=CT+1,A1=A_CT_",0)",@A1=" "_$S(G=1:" Name",1:"Address")_" = "_DVBADR(G)
- I $D(DVBZIP),DVBZIP'?9" " S T1=" ZIP = "_DVBZIP D LIN
- 2 ;
- I $D(DVBVET),$P(DVBVET,U,1)'="C" S T1=" Sex = "_$S($P(DVBVET,U,3)="M":"MALE",$P(DVBVET,U,3)="F":"FEMALE",1:"")_$E(BL,1,29)_$S($P(DVBVET,U,2)=" ":"",1:"BLIND Ind.") D LIN I 1
- E I $D(DVBBIR) S T1=" Sex = "_$S($P(DVBBIR,U,25)="M":"MALE",$P(DVBBIR,U,25)="F":"FEMALE",1:"") D LIN
- ;
- I $D(DVBDOB),DVBDOB?8N S M=$E(DVBDOB,1,2) D MM^DVBHQM11 S T1="Date of Birth = "_M_" "_$S(+$E(DVBDOB,3,4)>0:$E(DVBDOB,3,4)_", ",1:" ")_$E(DVBDOB,5,8) D LIN
- I $D(DVBP(6)),$P(DVBP(6),U) S M=$E(DVBP(6),1,2) D MM^DVBHQM11 S T1="Date of Death = "_M_" "_$S(+$E(DVBP(6),3,4)>0:$E(DVBP(6),3,4)_", ",1:" ")_$E(DVBP(6),5,8) D LIN
- ;;;I $D(DVBP(6)),$P(DVBP(6),U) S Y=$P(DVBP(6),U) D DD S T1="Date of Death = "_Y D LIN
- P6 I $P($G(DVBREF),U)'?9N I $D(DVBSSN),+DVBSSN S T1=" VBA SSN = "_DVBSSN D VSS,LIN
- P61 D P4^DVBHQM11
- ;
- D BLOCK^DVBHQM12
- ;
- 10 ;if DVBCSVC(2) is populated, kill DVBCSVC(1) - DVB*4*49
- I $G(DVBCSVC(2))]"" K DVBCSVC(1)
- I $D(DVBCSVC) S T1=" Char of Svc: " F I=0:0 S I=$O(DVBCSVC(I)) D:I="" LIN Q:I="" S Y=DVBCSVC(I) D DISCHG:I=1 S:I>1 Y=$$DISCH2(DVBCSVC(I)) S T1=T1_Y
- ;
- ;Additional Service is no longer being sent, DVB*4*49
- ;
- ;DVB*4.0*65
- D P1^DVBHQM11,P6^DVBHQM11,P5^DVBHQM11,P3^DVBHQM11
- ;
- 11 K DVBNMREC,DVBBOSRC,DVBCSVCN,DVBEODN,DVBRADN,DVBSNREC,DVBPNAM,DVBSN,DVBCSVC,DVBPOA,DVBRAD,DVBEOD,DVBPOWD,DVBTOTAS,DVBASVC,DVBNM,DVBNSVC,DVBPOW,DVBSN,DVBBOS,DVBCN,DVBDOB,DVBADRLN,DVBZIP,DVBNAM,DVBADR,DVBSSN
- ;
- ;I $D(DVBDXPCT) S T1=" Combined % Disability = "_+DVBDXPCT D LIN
- ;I $D(DVBDXNO),+DVBDXNO S T1=" Disabilities = "_DVBDXNO D LIN
- ;I $D(DVBDXX) S T1=" Additional Disabilities = "_DVBDXX D LIN
- ;
- S T1="DISABILITIES" D LIN
- S T1="Combined %="_$S($D(DVBDXPCT):+DVBDXPCT,1:" ")_" "
- S T1=T1_"Disab. in Record="_$S($D(DVBDXNO):DVBDXNO,1:" ")
- I $G(DVBEFF)]"",DVBEFF'=" " S M=$E(DVBEFF,1,2) D MM^DVBHQM11 S DVBEFF=M_" "_$E(DVBEFF,3,4)_","_$E(DVBEFF,5,8)
- S T1=T1_" Eff. Date of Comb. Eval.="_$G(DVBEFF)
- D LIN S T1="" D LIN
- I $D(DVBDX)>9 D
- . S T1=" "
- . S T1=T1_" Orig Curr" D LIN
- . S T1=" SC Disability "
- . S T1=T1_" % Extr Eff Dt Eff Dt"
- . D LIN
- ;
- DX I $D(DVBDX)>9 F I=0:0 S I=$O(DVBDX(I)) Q:'I!(I>DVBDXNO) S Y=DVBDX(I) D DX1 I +Y S T1=Y D LIN
- ;
- BBIRLS I $G(DVBDXVER)="N" D ERR
- S T1=" " D LIN
- K DVBFL,DVBDXX,DVBDXNO,DVBDX,DVBDXPCT
- G EN^DVBHQM2
- ;
- SVC ;
- ;
- DISCHG S DVBV1=Y,Y=$S(Y=1:"HONORABLE ",Y=2:"OTHER THAN HONORABLE ",Y=3:"DISHONORABLE ",Y=4:"HON VA PUR. ",Y=5:"DISHON VA PUR. ",Y=0!(Y=" "):"UNVERIFIED ",1:" ")
- Q
- DISCH2(DVBD) ;this will handle codes from Corporate
- ;DVBD is the code for character of discharge
- N DVBDD
- S DVBD=$$UP^XLFSTR(DVBD)
- S DVBDD=$S(DVBD="HON":"Honorable",DVBD="BAD":"Bad Conduct",DVBD="DIS":"Dishonorable",DVBD="DVA":"Dis for VA Pur",DVBD="GEN":"General",DVBD="HVA":"Hon for VA Pur",DVBD="OTH":"Other than Hon",1:"")
- I $G(DVBDD)="" S DVBDD=$S(DVBD="UNC":"Unchar",DVBD="UEL":"Unchar-Entry Lev",DVBD="UHC":"Under Hon Cond",DVBD="UNK":"Unknown",DVBD="UNS":"Unsuitable",DVBD="UNV":"Unverified",1:DVBD)
- S DVBD=" "
- S DVBD=DVBDD_$E(DVBD,$L(DVBDD)+1,22) ;longest str=21 chars, pad w/1 char
- Q DVBD
- ;
- ASVC S Z=$S(Z=0:"None",Z=1:"Wartime and/or Peacetime",Z=2:"Peacetime",Z=3:"Less than 90 days wartime, has SC disability",Z=4:"18-29 months continuous service (CH34)",Z=" ":"Not an issue",1:Z) Q
- ;
- DX1 I '+Y!(Y["-") S Y=0 Q
- ;I '+$P(Y,U,2) S DVBDX(I)=+Y_" - "_$E(BL,1,32)
- I '+$P(Y,U,2) S DVBDX(I)=+Y_" - Code not in local file-see ADPAC"
- E S DVBDX(I)=+Y_"-"_$E($P(^DIC(31,$P(Y,U,2),0),U),1,43)_$E(BL,1,43-$L($P(^(0),U)))
- N DVBCURR,DVBORIG
- S DVBORIG=$S($P(Y,U,5)]"":$P(Y,U,5),1:"")
- S DVBCURR=$S($P(Y,U,6)]"":$P(Y,U,6),1:"")
- I $G(DVBORIG)'=" ",$G(DVBORIG)]"" S M=$E(DVBORIG,1,2) D MM^DVBHQM11 S DVBORIG=M_" "_$E(DVBORIG,3,4)_","_$E(DVBORIG,5,8)
- I $G(DVBCURR)'=" ",$G(DVBCURR)]"" S M=$E(DVBCURR,1,2) D MM^DVBHQM11 S DVBCURR=M_" "_$E(DVBCURR,3,4)_","_$E(DVBCURR,5,8)
- S DVBDX(I)=DVBDX(I)_"-"_$S($P(Y,U,3)'["X":$P(Y,U,3),$P(Y,U,3)="X0":"100",1:"..")_"%-"_$S($P(Y,U,4)]"":$P(Y,U,4),1:" ")_"-"
- S DVBDX(I)=DVBDX(I)_$S($G(DVBORIG)]"":DVBORIG,1:$E(BL,1,11))_"-"_$G(DVBCURR)
- S Y=DVBDX(I)
- Q
- ;
- VSS I $D(DVBP(6)) S C=$P(DVBP(6),U,3) I C S T1=T1_$S(C=1:" Verified SSA",C=2:" Verified VBA",C=4:" Verified by BIRLS",C=9:" SSA Verified No Number Exists",C=0:" Un verified",C=3:" Not Required, Child Under 2",1:" "_C) K C
- Q
- ;
- ERR ;These are the error messages for the BIRLS only equivalent record
- ;which is possibly not verified (DVB*4*49)
- ;
- S T1=" " D LIN
- S T1=" Diagnostic Verified Indicator is NO." D LIN
- S T1=" Verify Service Connections "_$S($D(DVBFL):"at "_DVBFL,1:"with VBA") D LIN
- S T1=" " D LIN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHQM1 5709 printed Feb 18, 2025@23:25:02 Page 2
- DVBHQM1 ;ISC-ALBANY/PKE/JLU - create mail message;8/27/05 4:18pm
- +1 ;;4.0;HINQ;**49,65**;03/25/92;Build 19
- +2 GOTO EN
- LIN if CT>200
- QUIT
- SET CT=CT+1
- SET A1=A_CT_",0)"
- SET @A1=T1
- QUIT
- DD if Y
- SET Y=$SELECT($EXTRACT(Y,4,5):$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$EXTRACT(Y,4,5))_" ",1:"")_$SELECT($EXTRACT(Y,6,7):+$EXTRACT(Y,6,7)_",",1:"")_($EXTRACT(Y,1,3)+1700)_$PIECE("@"_$EXTRACT(Y_0,9,10)_":"_...
- ... $EXTRACT(Y_"000",11,12),"^",Y[".")
- if $LENGTH(Y)=10
- SET Y=Y_" "
- QUIT
- +1 ;
- EN SET DVBCTN=CT+1
- +1 IF $DATA(DVBNAME)
- IF DVBNAME'?7" "
- SET T1=" VBA name = "_DVBNAME
- DO LIN
- +2 IF $DATA(DVBPNAM)
- SET T1=" Prior names ="
- DO LIN
- SET T1=""
- FOR I=0:0
- SET I=$ORDER(DVBPNAM(I))
- if I=""
- QUIT
- Begin DoDot:1
- +3 SET T1=" "_DVBPNAM(I)
- +4 DO LIN
- End DoDot:1
- +5 ;I $D(DVBPNAM) D LIN
- +6 IF $DATA(DVBADRLN)
- IF +DVBADRLN
- FOR G=1:1:$SELECT(DVBADRLN<7:DVBADRLN,1:0)
- IF $DATA(DVBADR(G))
- SET CT=CT+1
- SET A1=A_CT_",0)"
- SET @A1=" "_$SELECT(G=1:" Name",1:"Address")_" = "_DVBADR(G)
- +7 IF $DATA(DVBZIP)
- IF DVBZIP'?9" "
- SET T1=" ZIP = "_DVBZIP
- DO LIN
- 2 ;
- +1 IF $DATA(DVBVET)
- IF $PIECE(DVBVET,U,1)'="C"
- SET T1=" Sex = "_$SELECT($PIECE(DVBVET,U,3)="M":"MALE",$PIECE(DVBVET,U,3)="F":"FEMALE",1:"")_$EXTRACT(BL,1,29)_$SELECT($PIECE(DVBVET,U,2)=" ":"",1:"BLIND Ind.")
- DO LIN
- IF 1
- +2 IF '$TEST
- IF $DATA(DVBBIR)
- SET T1=" Sex = "_$SELECT($PIECE(DVBBIR,U,25)="M":"MALE",$PIECE(DVBBIR,U,25)="F":"FEMALE",1:"")
- DO LIN
- +3 ;
- +4 IF $DATA(DVBDOB)
- IF DVBDOB?8N
- SET M=$EXTRACT(DVBDOB,1,2)
- DO MM^DVBHQM11
- SET T1="Date of Birth = "_M_" "_$SELECT(+$EXTRACT(DVBDOB,3,4)>0:$EXTRACT(DVBDOB,3,4)_", ",1:" ")_$EXTRACT(DVBDOB,5,8)
- DO LIN
- +5 IF $DATA(DVBP(6))
- IF $PIECE(DVBP(6),U)
- SET M=$EXTRACT(DVBP(6),1,2)
- DO MM^DVBHQM11
- SET T1="Date of Death = "_M_" "_$SELECT(+$EXTRACT(DVBP(6),3,4)>0:$EXTRACT(DVBP(6),3,4)_", ",1:" ")_$EXTRACT(DVBP(6),5,8)
- DO LIN
- +6 ;;;I $D(DVBP(6)),$P(DVBP(6),U) S Y=$P(DVBP(6),U) D DD S T1="Date of Death = "_Y D LIN
- P6 IF $PIECE($GET(DVBREF),U)'?9N
- IF $DATA(DVBSSN)
- IF +DVBSSN
- SET T1=" VBA SSN = "_DVBSSN
- DO VSS
- DO LIN
- P61 DO P4^DVBHQM11
- +1 ;
- +2 DO BLOCK^DVBHQM12
- +3 ;
- 10 ;if DVBCSVC(2) is populated, kill DVBCSVC(1) - DVB*4*49
- +1 IF $GET(DVBCSVC(2))]""
- KILL DVBCSVC(1)
- +2 IF $DATA(DVBCSVC)
- SET T1=" Char of Svc: "
- FOR I=0:0
- SET I=$ORDER(DVBCSVC(I))
- if I=""
- DO LIN
- if I=""
- QUIT
- SET Y=DVBCSVC(I)
- if I=1
- DO DISCHG
- if I>1
- SET Y=$$DISCH2(DVBCSVC(I))
- SET T1=T1_Y
- +3 ;
- +4 ;Additional Service is no longer being sent, DVB*4*49
- +5 ;
- +6 ;DVB*4.0*65
- +7 DO P1^DVBHQM11
- DO P6^DVBHQM11
- DO P5^DVBHQM11
- DO P3^DVBHQM11
- +8 ;
- 11 KILL DVBNMREC,DVBBOSRC,DVBCSVCN,DVBEODN,DVBRADN,DVBSNREC,DVBPNAM,DVBSN,DVBCSVC,DVBPOA,DVBRAD,DVBEOD,DVBPOWD,DVBTOTAS,DVBASVC,DVBNM,DVBNSVC,DVBPOW,DVBSN,DVBBOS,DVBCN,DVBDOB,DVBADRLN,DVBZIP,DVBNAM,DVBADR,DVBSSN
- +1 ;
- +2 ;I $D(DVBDXPCT) S T1=" Combined % Disability = "_+DVBDXPCT D LIN
- +3 ;I $D(DVBDXNO),+DVBDXNO S T1=" Disabilities = "_DVBDXNO D LIN
- +4 ;I $D(DVBDXX) S T1=" Additional Disabilities = "_DVBDXX D LIN
- +5 ;
- +6 SET T1="DISABILITIES"
- DO LIN
- +7 SET T1="Combined %="_$SELECT($DATA(DVBDXPCT):+DVBDXPCT,1:" ")_" "
- +8 SET T1=T1_"Disab. in Record="_$SELECT($DATA(DVBDXNO):DVBDXNO,1:" ")
- +9 IF $GET(DVBEFF)]""
- IF DVBEFF'=" "
- SET M=$EXTRACT(DVBEFF,1,2)
- DO MM^DVBHQM11
- SET DVBEFF=M_" "_$EXTRACT(DVBEFF,3,4)_","_$EXTRACT(DVBEFF,5,8)
- +10 SET T1=T1_" Eff. Date of Comb. Eval.="_$GET(DVBEFF)
- +11 DO LIN
- SET T1=""
- DO LIN
- +12 IF $DATA(DVBDX)>9
- Begin DoDot:1
- +13 SET T1=" "
- +14 SET T1=T1_" Orig Curr"
- DO LIN
- +15 SET T1=" SC Disability "
- +16 SET T1=T1_" % Extr Eff Dt Eff Dt"
- +17 DO LIN
- End DoDot:1
- +18 ;
- DX IF $DATA(DVBDX)>9
- FOR I=0:0
- SET I=$ORDER(DVBDX(I))
- if 'I!(I>DVBDXNO)
- QUIT
- SET Y=DVBDX(I)
- DO DX1
- IF +Y
- SET T1=Y
- DO LIN
- +1 ;
- BBIRLS IF $GET(DVBDXVER)="N"
- DO ERR
- +1 SET T1=" "
- DO LIN
- +2 KILL DVBFL,DVBDXX,DVBDXNO,DVBDX,DVBDXPCT
- +3 GOTO EN^DVBHQM2
- +4 ;
- SVC ;
- +1 ;
- DISCHG SET DVBV1=Y
- SET Y=$SELECT(Y=1:"HONORABLE ",Y=2:"OTHER THAN HONORABLE ",Y=3:"DISHONORABLE ",Y=4:"HON VA PUR. ",Y=5:"DISHON VA PUR. ",Y=0!(Y=" "):"UNVERIFIED ",1:" ")
- +1 QUIT
- DISCH2(DVBD) ;this will handle codes from Corporate
- +1 ;DVBD is the code for character of discharge
- +2 NEW DVBDD
- +3 SET DVBD=$$UP^XLFSTR(DVBD)
- +4 SET DVBDD=$SELECT(DVBD="HON":"Honorable",DVBD="BAD":"Bad Conduct",DVBD="DIS":"Dishonorable",DVBD="DVA":"Dis for VA Pur",DVBD="GEN":"General",DVBD="HVA":"Hon for VA Pur",DVBD="OTH":"Other than Hon",1:"")
- +5 IF $GET(DVBDD)=""
- SET DVBDD=$SELECT(DVBD="UNC":"Unchar",DVBD="UEL":"Unchar-Entry Lev",DVBD="UHC":"Under Hon Cond",DVBD="UNK":"Unknown",DVBD="UNS":"Unsuitable",DVBD="UNV":"Unverified",1:DVBD)
- +6 SET DVBD=" "
- +7 ;longest str=21 chars, pad w/1 char
- SET DVBD=DVBDD_$EXTRACT(DVBD,$LENGTH(DVBDD)+1,22)
- +8 QUIT DVBD
- +9 ;
- ASVC SET Z=$SELECT(Z=0:"None",Z=1:"Wartime and/or Peacetime",Z=2:"Peacetime",Z=3:"Less than 90 days wartime, has SC disability",Z=4:"18-29 months continuous service (CH34)",Z=" ":"Not an issue",1:Z)
- QUIT
- +1 ;
- DX1 IF '+Y!(Y["-")
- SET Y=0
- QUIT
- +1 ;I '+$P(Y,U,2) S DVBDX(I)=+Y_" - "_$E(BL,1,32)
- +2 IF '+$PIECE(Y,U,2)
- SET DVBDX(I)=+Y_" - Code not in local file-see ADPAC"
- +3 IF '$TEST
- SET DVBDX(I)=+Y_"-"_$EXTRACT($PIECE(^DIC(31,$PIECE(Y,U,2),0),U),1,43)_$EXTRACT(BL,1,43-$LENGTH($PIECE(^(0),U)))
- +4 NEW DVBCURR,DVBORIG
- +5 SET DVBORIG=$SELECT($PIECE(Y,U,5)]"":$PIECE(Y,U,5),1:"")
- +6 SET DVBCURR=$SELECT($PIECE(Y,U,6)]"":$PIECE(Y,U,6),1:"")
- +7 IF $GET(DVBORIG)'=" "
- IF $GET(DVBORIG)]""
- SET M=$EXTRACT(DVBORIG,1,2)
- DO MM^DVBHQM11
- SET DVBORIG=M_" "_$EXTRACT(DVBORIG,3,4)_","_$EXTRACT(DVBORIG,5,8)
- +8 IF $GET(DVBCURR)'=" "
- IF $GET(DVBCURR)]""
- SET M=$EXTRACT(DVBCURR,1,2)
- DO MM^DVBHQM11
- SET DVBCURR=M_" "_$EXTRACT(DVBCURR,3,4)_","_$EXTRACT(DVBCURR,5,8)
- +9 SET DVBDX(I)=DVBDX(I)_"-"_$SELECT($PIECE(Y,U,3)'["X":$PIECE(Y,U,3),$PIECE(Y,U,3)="X0":"100",1:"..")_"%-"_$SELECT($PIECE(Y,U,4)]"":$PIECE(Y,U,4),1:" ")_"-"
- +10 SET DVBDX(I)=DVBDX(I)_$SELECT($GET(DVBORIG)]"":DVBORIG,1:$EXTRACT(BL,1,11))_"-"_$GET(DVBCURR)
- +11 SET Y=DVBDX(I)
- +12 QUIT
- +13 ;
- VSS IF $DATA(DVBP(6))
- SET C=$PIECE(DVBP(6),U,3)
- IF C
- SET T1=T1_$SELECT(C=1:" Verified SSA",C=2:" Verified VBA",C=4:" Verified by BIRLS",C=9:" SSA Verified No Number Exists",C=0:" Un verified",C=3:" Not Required, Child Under 2",1:" "_C)
- KILL C
- +1 QUIT
- +2 ;
- ERR ;These are the error messages for the BIRLS only equivalent record
- +1 ;which is possibly not verified (DVB*4*49)
- +2 ;
- +3 SET T1=" "
- DO LIN
- +4 SET T1=" Diagnostic Verified Indicator is NO."
- DO LIN
- +5 SET T1=" Verify Service Connections "_$SELECT($DATA(DVBFL):"at "_DVBFL,1:"with VBA")
- DO LIN
- +6 SET T1=" "
- DO LIN
- +7 QUIT