- DVBHQM11 ;ISC-ALBANY/JLU/PKE - create mail message;10/27/87 10:50
- ;;4.0;HINQ;**7,20,49,65**;03/25/92;Build 19
- ;
- LIN Q:CT>100 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
- ;
- MM S M=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",M) Q
- ;
- P1 Q:'$D(DVBP(1))
- S T1=$P(DVBP(1),U,4)
- I T1'="" D
- . ;VBA is no longer sending entitlement code, but AAC is computing a
- . ;type of benefit code from the information sent. DVB*4*49
- . S T1="Type Benefit: "_$S($P(DVBP(1),U,4)="01":"Compensation",$P(DVBP(1),U,4)="0L":"Pension",1:" ")
- . D LIN
- ;VBA will be sending all records as Type "A" records, so Record Type
- ;will no longer display
- Q
- ;
- P2 Q:'$D(DVBP(2))
- S T1=" " D LIN S T1=$P(DVBP(2),U) I T1'=" " S Z=$O(^DVB(395.2,"B",T1,"")) I Z S S=" Anatomical loss = ",ST=$P(^DVB(395.2,Z,0),U,2)_" - "_T1 D WRAP
- S T1=$P(DVBP(2),U,3) I T1'=" " S Z=$O(^DVB(395.2,"B",T1,"")) I Z S T1=" Loss of use = "_$P(^DVB(395.2,Z,0),U,2)_" - "_T1 D LIN
- S T1=$P(DVBP(2),U,4) I T1'=" " D OLC^DVBHQM13 I Z'="" S T1=" Other loss = "_Z_" - "_T1 D LIN
- S T1=$P(DVBP(2),U,5) D VMV^DVBHQM13 I Z'="" S S=" Vet married Vet = ",ST=Z D WRAP
- ;Special Monthly Comp. will no longer be sent by VBA - DVB*4*49
- ;Special Provision will no longer be sent by VBA - DVB*4*49
- Q
- ;
- P3 Q ;P3 concerns future data - after DVB*4*49 there will be none
- Q:'$D(DVBP(3))
- I $P(DVBP(3),U,3)="RR" S T1="Future data present - contact RO !!" D LIN Q
- I $P(DVBFUE,U,22) S T1="Amount PFOP Deduction = "_"$"_$E($P(DVBFUE,U,22),1,4)_"."_$E($P(DVBFUE,U,22),5,6) D LIN Q
- I $P(DVBP(3),U)="A" D T4 F XX=1:1:T4 S T3=$P(DVBP(3),U,XX+2) I T3?7N1E S M=$E(T3,5,6) D MM,T5,EMP,HD S ST=" "_M_", "_$E(T3,1,4)_" "_$S(Z:$P(^DVB(395.4,Z,0),U,2),1:"")_" - "_DVBV1,S=" " D WRAP
- D EMP Q
- ;
- P4 Q:'$D(DVBREF)
- I $P(DVBREF,U,3)?9N S T1="Cross Reference number = "_$P(DVBREF,U,3) D LIN
- I $P(DVBREF,U)?9N S T1=" VBA SSN = "_$P(DVBREF,U) D VSS,LIN
- S T1=" " D LIN
- Q
- ;
- P5 Q:'$D(DVBP(5)) S T1=$P(DVBP(5),U) I T1 S T1="PFOP Balance : "_" $"_+$E(T1,1,6)_"."_$E(T1,7,8) D LIN Q
- ;
- Q
- ;
- ;DVB*4.0*65
- P6 ;
- I $P(DVBP(1),U,10)>0 S M=$E($P(DVBP(1),U,10),1,2) D MM^DVBHQM11 D
- . S T1="Pension Award Eff Date = "_M_" "_$S(+$E($P(DVBP(1),U,10),3,4)>0:$E($P(DVBP(1),U,10),3,4)_", ",1:" ")_$E($P(DVBP(1),U,10),5,8) S:$P(DVBP(1),U,11)]"" T1=T1_" Reason code = "_$P(DVBP(1),U,11) D LIN
- I $P(DVBP(1),U,12)>0 S M=$E($P(DVBP(1),U,12),1,2) D MM^DVBHQM11 D
- . S T1=" Pension Terminated = "_M_" "_$S(+$E($P(DVBP(1),U,12),3,4)>0:$E($P(DVBP(1),U,12),3,4)_", ",1:" ")_$E($P(DVBP(1),U,12),5,8) S:$P(DVBP(1),U,13)]"" T1=T1_" Reason code = "_$P(DVBP(1),U,13) D LIN
- I $P(DVBP(1),U,14)'?1" "." " S T1=" Reason code = "_$P(DVBP(1),U,14) D LIN
- I $P(DVBP(1),U,15)'?1" "." " S T1=" Reason code = "_$P(DVBP(1),U,15) D LIN
- I $P(DVBP(1),U,16)'?1" "." " S T1=" Reason code = "_$P(DVBP(1),U,16) D LIN
- ;
- Q
- ;
- EMP S T1=" " D LIN Q
- ;
- HD S T1="Diary data:" D LIN Q
- T4 S T4=$P(DVBP(3),U,2) Q
- ;
- T5 S DVBV1=$E(T3,7,8)
- I DVBV1?1N1A!(DVBV1["{") S DVBV2=2 D SIGN^DVBHUTIL
- S Z=$O(^DVB(395.4,"B",DVBV1,""))
- Q
- ;
- WRAP S B=$L(S),GL=$P((($L(ST)+B/78)+.9),"."),SP=1,V=78-B,$P(T," ",B+1)=""
- F LP=1:1:GL S Z=$E(ST,V*LP) D:Z=" "!(Z="") SET D:Z'=" "&(Z'="") PAR
- K GL,LP,LP1,Z,Z1,EP,SP,ST,B,V,T,S Q
- SET S T1=$E(ST,SP,V*LP) S:SP=1 T1=S_T1 S:SP'=1 T1=T_T1 S SP=V*LP+1 D LIN Q
- PAR F LP1=1:1 S EP=(V*LP)-LP1,Z1=$E(ST,EP) Q:Z1=" "
- S T1=$E(ST,SP,EP) S:SP=1 T1=S_T1 S:SP'=1 T1=T_T1 S SP=EP+1 D LIN Q
- ;
- VSS I $D(DVBP(1)) S C=$P(DVBP(1),U,8) 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:" Unverified",C=3:" Not Required, Child Under 2",1:" "_C) K C
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHQM11 4097 printed Feb 18, 2025@23:25:03 Page 2
- DVBHQM11 ;ISC-ALBANY/JLU/PKE - create mail message;10/27/87 10:50
- +1 ;;4.0;HINQ;**7,20,49,65**;03/25/92;Build 19
- +2 ;
- LIN if CT>100
- 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 ;
- MM SET M=$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",M)
- QUIT
- +1 ;
- P1 if '$DATA(DVBP(1))
- QUIT
- +1 SET T1=$PIECE(DVBP(1),U,4)
- +2 IF T1'=""
- Begin DoDot:1
- +3 ;VBA is no longer sending entitlement code, but AAC is computing a
- +4 ;type of benefit code from the information sent. DVB*4*49
- +5 SET T1="Type Benefit: "_$SELECT($PIECE(DVBP(1),U,4)="01":"Compensation",$PIECE(DVBP(1),U,4)="0L":"Pension",1:" ")
- +6 DO LIN
- End DoDot:1
- +7 ;VBA will be sending all records as Type "A" records, so Record Type
- +8 ;will no longer display
- +9 QUIT
- +10 ;
- P2 if '$DATA(DVBP(2))
- QUIT
- +1 SET T1=" "
- DO LIN
- SET T1=$PIECE(DVBP(2),U)
- IF T1'=" "
- SET Z=$ORDER(^DVB(395.2,"B",T1,""))
- IF Z
- SET S=" Anatomical loss = "
- SET ST=$PIECE(^DVB(395.2,Z,0),U,2)_" - "_T1
- DO WRAP
- +2 SET T1=$PIECE(DVBP(2),U,3)
- IF T1'=" "
- SET Z=$ORDER(^DVB(395.2,"B",T1,""))
- IF Z
- SET T1=" Loss of use = "_$PIECE(^DVB(395.2,Z,0),U,2)_" - "_T1
- DO LIN
- +3 SET T1=$PIECE(DVBP(2),U,4)
- IF T1'=" "
- DO OLC^DVBHQM13
- IF Z'=""
- SET T1=" Other loss = "_Z_" - "_T1
- DO LIN
- +4 SET T1=$PIECE(DVBP(2),U,5)
- DO VMV^DVBHQM13
- IF Z'=""
- SET S=" Vet married Vet = "
- SET ST=Z
- DO WRAP
- +5 ;Special Monthly Comp. will no longer be sent by VBA - DVB*4*49
- +6 ;Special Provision will no longer be sent by VBA - DVB*4*49
- +7 QUIT
- +8 ;
- P3 ;P3 concerns future data - after DVB*4*49 there will be none
- QUIT
- +1 if '$DATA(DVBP(3))
- QUIT
- +2 IF $PIECE(DVBP(3),U,3)="RR"
- SET T1="Future data present - contact RO !!"
- DO LIN
- QUIT
- +3 IF $PIECE(DVBFUE,U,22)
- SET T1="Amount PFOP Deduction = "_"$"_$EXTRACT($PIECE(DVBFUE,U,22),1,4)_"."_$EXTRACT($PIECE(DVBFUE,U,22),5,6)
- DO LIN
- QUIT
- +4 IF $PIECE(DVBP(3),U)="A"
- DO T4
- FOR XX=1:1:T4
- SET T3=$PIECE(DVBP(3),U,XX+2)
- IF T3?7N1E
- SET M=$EXTRACT(T3,5,6)
- DO MM
- DO T5
- DO EMP
- DO HD
- SET ST=" "_M_", "_$EXTRACT(T3,1,4)_" "_$SELECT(Z:$PIECE(^DVB(395.4,Z,0),U,2),1:"")_" - "_DVBV1
- SET S=" "
- DO WRAP
- +5 DO EMP
- QUIT
- +6 ;
- P4 if '$DATA(DVBREF)
- QUIT
- +1 IF $PIECE(DVBREF,U,3)?9N
- SET T1="Cross Reference number = "_$PIECE(DVBREF,U,3)
- DO LIN
- +2 IF $PIECE(DVBREF,U)?9N
- SET T1=" VBA SSN = "_$PIECE(DVBREF,U)
- DO VSS
- DO LIN
- +3 SET T1=" "
- DO LIN
- +4 QUIT
- +5 ;
- P5 if '$DATA(DVBP(5))
- QUIT
- SET T1=$PIECE(DVBP(5),U)
- IF T1
- SET T1="PFOP Balance : "_" $"_+$EXTRACT(T1,1,6)_"."_$EXTRACT(T1,7,8)
- DO LIN
- QUIT
- +1 ;
- +2 QUIT
- +3 ;
- +4 ;DVB*4.0*65
- P6 ;
- +1 IF $PIECE(DVBP(1),U,10)>0
- SET M=$EXTRACT($PIECE(DVBP(1),U,10),1,2)
- DO MM^DVBHQM11
- Begin DoDot:1
- +2 SET T1="Pension Award Eff Date = "_M_" "_$SELECT(+$EXTRACT($PIECE(DVBP(1),U,10),3,4)>0:$EXTRACT($PIECE(DVBP(1),U,10),3,4)_", ",1:" ")_$EXTRACT($PIECE(DVBP(1),U,10),5,8)
- if $PIECE(DVBP(1),U,11)]""
- SET T1=T1_" Reason code = "_$PIECE(DVBP(1),U,11)
- DO LIN
- End DoDot:1
- +3 IF $PIECE(DVBP(1),U,12)>0
- SET M=$EXTRACT($PIECE(DVBP(1),U,12),1,2)
- DO MM^DVBHQM11
- Begin DoDot:1
- +4 SET T1=" Pension Terminated = "_M_" "_$SELECT(+$EXTRACT($PIECE(DVBP(1),U,12),3,4)>0:$EXTRACT($PIECE(DVBP(1),U,12),3,4)_", ",1:" ")_$EXTRACT($PIECE(DVBP(1),U,12),5,8)
- if $PIECE(DVBP(1),U,13)]""
- SET T1=T1_" Reason code = "_$PIECE(DVBP(1),U,13)
- DO LIN
- End DoDot:1
- +5 IF $PIECE(DVBP(1),U,14)'?1" "." "
- SET T1=" Reason code = "_$PIECE(DVBP(1),U,14)
- DO LIN
- +6 IF $PIECE(DVBP(1),U,15)'?1" "." "
- SET T1=" Reason code = "_$PIECE(DVBP(1),U,15)
- DO LIN
- +7 IF $PIECE(DVBP(1),U,16)'?1" "." "
- SET T1=" Reason code = "_$PIECE(DVBP(1),U,16)
- DO LIN
- +8 ;
- +9 QUIT
- +10 ;
- EMP SET T1=" "
- DO LIN
- QUIT
- +1 ;
- HD SET T1="Diary data:"
- DO LIN
- QUIT
- T4 SET T4=$PIECE(DVBP(3),U,2)
- QUIT
- +1 ;
- T5 SET DVBV1=$EXTRACT(T3,7,8)
- +1 IF DVBV1?1N1A!(DVBV1["{")
- SET DVBV2=2
- DO SIGN^DVBHUTIL
- +2 SET Z=$ORDER(^DVB(395.4,"B",DVBV1,""))
- +3 QUIT
- +4 ;
- WRAP SET B=$LENGTH(S)
- SET GL=$PIECE((($LENGTH(ST)+B/78)+.9),".")
- SET SP=1
- SET V=78-B
- SET $PIECE(T," ",B+1)=""
- +1 FOR LP=1:1:GL
- SET Z=$EXTRACT(ST,V*LP)
- if Z=" "!(Z="")
- DO SET
- if Z'=" "&(Z'="")
- DO PAR
- +2 KILL GL,LP,LP1,Z,Z1,EP,SP,ST,B,V,T,S
- QUIT
- SET SET T1=$EXTRACT(ST,SP,V*LP)
- if SP=1
- SET T1=S_T1
- if SP'=1
- SET T1=T_T1
- SET SP=V*LP+1
- DO LIN
- QUIT
- PAR FOR LP1=1:1
- SET EP=(V*LP)-LP1
- SET Z1=$EXTRACT(ST,EP)
- if Z1=" "
- QUIT
- +1 SET T1=$EXTRACT(ST,SP,EP)
- if SP=1
- SET T1=S_T1
- if SP'=1
- SET T1=T_T1
- SET SP=EP+1
- DO LIN
- QUIT
- +2 ;
- VSS IF $DATA(DVBP(1))
- SET C=$PIECE(DVBP(1),U,8)
- 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:" Unverified",C=3:" Not Required, Child Under 2",1:" "_C)
- KILL C
- +1 QUIT