- EASECSC1 ;ALB/PHH,LBD,EG,ERC,JMM - LTC Co-Pay Test Screen Military Service ; 05/06/2006 4:17 PM
- ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,38,62,75,70,202,222**;Mar 15, 2001;Build 12
- ;
- ; Input -- DFN Patient IEN
- ; DGMTACT LTC Co-Pay Test Action
- ; DGVINI Veteran Individual Annual Income IEN
- ; DGVIRI Veteran Income Relation IEN
- ; DGVPRI Veteran Patient Relation IEN
- ; Output -- None
- ;
- EN ;Entry point
- N DGLTCEX,DGLTC,IORVON,IORVOFF
- D ^DGRPV
- D EASECRP6
- S X="IORVON;IORVOFF" D ENDR^%ZISS K X
- I $G(DGLTCEX) W !?2,$G(IORVON)," * VETERAN MAY BE EXEMPT FROM COPAY IF LTC EPISODE IS DUE TO THIS CONDITION.",$G(IORVOFF)
- S X="^2"
- S:$$PAUSE(0) X="^"
- G EN1^EASECSCR
- Q
- PAUSE(RESP) ; Prompt user for next page or quit
- N DIR,DIRUT,DUOUT,DTOUT,U,X,Y
- S DIR(0)="E"
- D ^DIR
- I 'Y S RESP=1
- Q RESP
- ;
- EASECRP6 ; Display the screen
- ; Note: This section was copied from ^DGRP6 and modified specifically
- ; to work with LTC.
- ;
- S (DGRPS,DGMTSCI)=1 D HD^EASECSCU F I=.32,.321,.322,.36,.52,.53 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
- S (DGRPW,Z)=1 D WW S Z=" Service Branch",Z1=24 D WW1^DGRPV S Z=" Service #",Z1=19 D WW1^DGRPV S Z=" Entered",Z1=12 D WW1^DGRPV S Z=" Separated",Z1=12 D WW1^DGRPV W " Discharge"
- W !?4,"--------------",?27,"---------",?46,"-------",?58,"---------",?70,"---------"
- N DGMSE D GETMSE^DGMSEUTL(DFN,.DGMSE) D S1 ;EAS*1.0*202 MSE's new .3216 multiple will be populated at this time, so use this instead of DGRP(.32)
- S Z=2,DGRPX=DGRP(.52) D WW W " POW: " S X=5,Z1=6 D YN W "From: " S X=7,Z1=13 D DAT W "To: " S X=8,Z1=12 D DAT W "War: ",$S($D(^DIC(22,+$P(DGRPX,"^",6),0)):$P(^(0),"^",2),1:"")
- S Z=3 D WW W " Combat: " S X=11,Z1=6 D YN W "From: " S X=13,Z1=13 D DAT W "To: " S X=14,Z1=12 D DAT W "Loc: ",$S($D(^DIC(22,+$P(DGRPX,"^",12),0)):$P(^(0),"^",2),1:"")
- S Z=4,DGRPX=DGRP(.321) D WW W " Vietnam: " S X=1,Z1=6 D YN W "From: " S X=4,Z1=13 D DAT W "To: " S X=5,X1=13 D DAT
- ; EAS*1*222 - Add THAILAND(U.S. OR ROYAL THAI MIL BASE):"THLD", LAOS:"LAOS", CAMBODIA(MIMOT OR KREK,KAMPONG CHAM): "CAMB", GUAM, AMERICAN SAMOA, OR TERRITORIAL WATERS:"GUAM", JOHNSTON ATOLL:"JHST"
- ; This is the Military Service screen within the LTC Co-Pay Test options
- ;S Z=5 D WW W " A/O Exp.: " S X=2,Z1=7,DGLTC=1 D YN W "Reg: " S X=7,Z1=11 D DAT W "Exam: " S X=9,Z1=11 D DAT W "A/O#: " S Z=$P(DGRPX,"^",10),Z1=8 D WW1^DGRPV S Z=$P(DGRPX,"^",13) W $S(Z="K":" DMZ",Z="V":"VIET",1:"")
- N EASTYPE
- S Z=5 D WW W " A/O Exp.: " S X=2,Z1=7,DGLTC=1 D YN W "Reg: " S X=7,Z1=11 D DAT W "Exam: " S X=9,Z1=11 D DAT W "A/O#: " S Z=$P(DGRPX,"^",10),Z1=8 D WW1^DGRPV S Z=$P(DGRPX,"^",13)
- S EASTYPE=$S(Z="B":" BWN",Z="K":" DMZ",Z="V":"VIET",Z="O":" OTH",Z="T":"THLD",Z="L":"LAOS",Z="C":"CAMB",Z="G":"GUAM",Z="J":"JHST",1:"")
- W EASTYPE
- ;
- S Z=6 D WW W " ION Rad.: " S X=3,Z1=7,DGLTC=1 D YN W "Reg: " S X=11,Z1=9 D DAT W "Method: "
- ; EAS*1*222 Modified the RADIATION EXPOSURE METHOD (#2,.3212) to get updated field definitions
- ;S X=$P(DGRPX,"^",12) W $S(X=2:"HIROSHIMA/NAGASAKI",X=3:"ATMOSPHERIC NUCLEAR TESTING",X=4:"H/N AND ATMOSPHERIC TESTING",X=5:"UNDERGROUND NUCLEAR TESTING",X=6:"EXPOSURE AT NUCLEAR FACILITY",X=7:"OTHER",1:"")
- W $$GET1^DIQ(2,DFN,.3212,"E")
- ; end EAS*1*222
- S DGRPX=DGRP(.322)
- F DGX=1,4,7,10 S X=DGX,Z=DGX-1/3+7 D WW W:DGX<10 " " W $S(DGX=1:" Lebanon",DGX=4:" Grenada",DGX=7:" Panama",1:" Gulf War"),": " S Z1=6 D YN W "From: " S X=DGX+1,Z1=13 D DAT W "To: " S X=DGX+2,Z1=12 D DAT
- S Z=11 D WW W " Somalia: " S (DGX,X)=16,Z1=6 D YN W "From: " S X=17,Z1=13 D DAT W "To: " S X=18,Z1=12 D DAT
- ; Contam name changed to SW Asia Conditions, DG*5.3*688
- S Z=12 D WW W " SW Asia Cond: " S X=13,Z1=7,DGLTC=1 D YN W "Reg: " S X=14,Z1=11 D DAT W "Exam: " S X=15,Z1=10 D DAT
- S Z=13 D WW S X=$P(DGRP(.36),"^",12)
- W " Mil Disab Retirement: ",$S(X=0:"NO",X=1:"YES",1:"")
- S Z=21 S X=$P(DGRP(.36),U,13)
- W " Dischrg Due to Disab: ",$S(X=1:"YES",X=0:"NO",1:"")
- S Z=14 D WW W " Dent Inj: " S DGRPX=DGRP(.36),X=8,Z1=28 D YN W "Teeth Extracted: " S X=9,Z1=9 D YN S DGRPD=0 I $P(DGRPX,"^",8)="Y",$P(DGRPX,"^",9)="Y" S DGRPD=1
- I DGRPD S I1="" F I=0:0 S I=$O(^DPT(DFN,.37,I)) Q:'I S I1=1,DGRPX=^(I,0) D DEN
- S DGRPX=DGRP(.322)
- S Z=15 D WW W " Yugoslavia: " S (DGX,X)=19,Z1=6 D YN W "From: " S X=20,Z1=13 D DAT W "To: " S X=21,Z1=12 D DAT
- S Z=16 D WW W " Purple Heart: " S DGRPX=DGRP(.53),X=1 D YN D
- . I $P($G(DGRPX),U)="Y",($P($G(DGRPX),U,2)]"") W ?26,"PH Status: "_$S($P($G(DGRPX),U,2)="1":"Pending",$P($G(DGRPX),U,2)="2":"In Process",$P($G(DGRPX),U,2)="3":"Confirmed",1:"")
- I $P($G(DGRPX),U)="N" D
- . S DGX=$P(DGRPX,U,3)
- . S DGX=$S($G(DGX)=1:"UNACCEPTABLE DOCUMENTATION",$G(DGX)=2:"NO DOCUMENTATION REC'D",$G(DGX)=3:"ENTERED IN ERROR",$G(DGX)=4:"UNSUPPORTED PURPLE HEART",$G(DGX)=5:"VAMC",$G(DGX)=6:"UNDELIVERABLE MAIL",1:"")
- . I $G(DGX)]"" W ?26,"PH Remarks: "_$S($G(DGX)]"":$G(DGX),1:"")
- S Z=17 D WW W " N/T Radium: " D ;N/T Radium Treatment expos.
- . N DGNT S DGRPX=$$GETCUR^DGNTAPI(DFN,"DGNT") W $G(DGNT("INTRP")) I $G(DGNT("INTRP"))["YES" W "*" S DGLTCEX=1
- Q K DGRPD,DGRPSV
- Q
- YN S Z=$S($P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N":"NO",$P(DGRPX,"^",X)="U":"UNK",1:"") S:Z="YES"&($G(DGLTC)) Z=Z_"*",DGLTCEX=1 D WW1^DGRPV K DGLTC Q
- DAT S Z=$P(DGRPX,"^",X) I Z']"" S Z=""
- E S Z=$$FMTE^XLFDT(Z,"5DZ")
- D WW1^DGRPV Q
- DEN W !?3," Trt Date: " S X=1,Z1=10 D DAT W "Cond.: ",$E($P(DGRPX,"^",2),1,45) Q
- S N DGRPSB S DGRPSB=+$P(DGRPX,U,DGRPSV+1) ;Service Branch
- W !?4,$S($D(^DIC(23,DGRPSB,0)):$E($P(^(0),"^",1),1,15),1:DGRPU) W:$$FV^DGRPMS(DGRPSB)=1 ?20,"("_$P(DGRP(.321),U,14)_")"
- W ?27,$S($P(DGRPX,"^",DGRPSV+4)]"":$P(DGRPX,"^",DGRPSV+4),1:DGRPU)
- F I=2,3 S X=$P(DGRPX,"^",DGRPSV+I),X=$S(X]"":$$FMTE^XLFDT(X,"5DZ"),1:"UNKNOWN") W ?$S(I=2:46,1:58),X
- W ?70,$S($D(^DIC(25,+$P(DGRPX,"^",DGRPSV),0)):$E($P(^(0),"^",1),1,9),1:"UNKNOWN") Q
- MR W !?19,"Receiving Military retirement in lieu of VA Compensation." Q
- WW ;Write number on screens for display and/or edit (Z=number)
- ; NOTE: This section was copied from WW^DGRPV and modified specifically
- ; for LTC. The code calling ^DGRPV has been redirected here.
- W:DGRPW !
- Q
- S1 ;Display MSE data from .3216 multiple EAS*1.0*202
- N DGMSECNT,DGRPSB
- F DGMSECNT=1:1:3 I $D(DGMSE(DGMSECNT)) D
- . S DGRPSB=$P(DGMSE(DGMSECNT),"^",3)
- . W !?4,$S($D(^DIC(23,DGRPSB,0)):$E($P(^DIC(23,DGRPSB,0),"^",1),1,15),1:DGRPU) W:$$FV^DGRPMS(DGRPSB)=1 ?20,"("_$P(DGRP(.321),U,14)_")"
- . W ?27,$P(DGMSE(DGMSECNT),"^",5)
- . F I=1,2 S X=$P(DGMSE(DGMSECNT),"^",I),X=$S(X]"":$$FMTE^XLFDT(X,"5DZ"),1:"UNKNOWN") W ?$S(I=1:46,2:58),X
- . W ?70,$S($D(^DIC(25,+$P(DGMSE(DGMSECNT),"^",6),0)):$E($P(^DIC(25,$P(DGMSE(DGMSECNT),"^",6),0),"^",1),1,9),1:"UNKNOWN")
- . Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASECSC1 6869 printed Mar 13, 2025@20:58:50 Page 2
- EASECSC1 ;ALB/PHH,LBD,EG,ERC,JMM - LTC Co-Pay Test Screen Military Service ; 05/06/2006 4:17 PM
- +1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,38,62,75,70,202,222**;Mar 15, 2001;Build 12
- +2 ;
- +3 ; Input -- DFN Patient IEN
- +4 ; DGMTACT LTC Co-Pay Test Action
- +5 ; DGVINI Veteran Individual Annual Income IEN
- +6 ; DGVIRI Veteran Income Relation IEN
- +7 ; DGVPRI Veteran Patient Relation IEN
- +8 ; Output -- None
- +9 ;
- EN ;Entry point
- +1 NEW DGLTCEX,DGLTC,IORVON,IORVOFF
- +2 DO ^DGRPV
- +3 DO EASECRP6
- +4 SET X="IORVON;IORVOFF"
- DO ENDR^%ZISS
- KILL X
- +5 IF $GET(DGLTCEX)
- WRITE !?2,$GET(IORVON)," * VETERAN MAY BE EXEMPT FROM COPAY IF LTC EPISODE IS DUE TO THIS CONDITION.",$GET(IORVOFF)
- +6 SET X="^2"
- +7 if $$PAUSE(0)
- SET X="^"
- +8 GOTO EN1^EASECSCR
- +9 QUIT
- PAUSE(RESP) ; Prompt user for next page or quit
- +1 NEW DIR,DIRUT,DUOUT,DTOUT,U,X,Y
- +2 SET DIR(0)="E"
- +3 DO ^DIR
- +4 IF 'Y
- SET RESP=1
- +5 QUIT RESP
- +6 ;
- EASECRP6 ; Display the screen
- +1 ; Note: This section was copied from ^DGRP6 and modified specifically
- +2 ; to work with LTC.
- +3 ;
- +4 SET (DGRPS,DGMTSCI)=1
- DO HD^EASECSCU
- FOR I=.32,.321,.322,.36,.52,.53
- SET DGRP(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
- +5 SET (DGRPW,Z)=1
- DO WW
- SET Z=" Service Branch"
- SET Z1=24
- DO WW1^DGRPV
- SET Z=" Service #"
- SET Z1=19
- DO WW1^DGRPV
- SET Z=" Entered"
- SET Z1=12
- DO WW1^DGRPV
- SET Z=" Separated"
- SET Z1=12
- DO WW1^DGRPV
- WRITE " Discharge"
- +6 WRITE !?4,"--------------",?27,"---------",?46,"-------",?58,"---------",?70,"---------"
- +7 ;EAS*1.0*202 MSE's new .3216 multiple will be populated at this time, so use this instead of DGRP(.32)
- NEW DGMSE
- DO GETMSE^DGMSEUTL(DFN,.DGMSE)
- DO S1
- +8 SET Z=2
- SET DGRPX=DGRP(.52)
- DO WW
- WRITE " POW: "
- SET X=5
- SET Z1=6
- DO YN
- WRITE "From: "
- SET X=7
- SET Z1=13
- DO DAT
- WRITE "To: "
- SET X=8
- SET Z1=12
- DO DAT
- WRITE "War: ",$SELECT($DATA(^DIC(22,+$PIECE(DGRPX,"^",6),0)):$PIECE(^(0),"^",2),1:"")
- +9 SET Z=3
- DO WW
- WRITE " Combat: "
- SET X=11
- SET Z1=6
- DO YN
- WRITE "From: "
- SET X=13
- SET Z1=13
- DO DAT
- WRITE "To: "
- SET X=14
- SET Z1=12
- DO DAT
- WRITE "Loc: ",$SELECT($DATA(^DIC(22,+$PIECE(DGRPX,"^",12),0)):$PIECE(^(0),"^",2),1:"")
- +10 SET Z=4
- SET DGRPX=DGRP(.321)
- DO WW
- WRITE " Vietnam: "
- SET X=1
- SET Z1=6
- DO YN
- WRITE "From: "
- SET X=4
- SET Z1=13
- DO DAT
- WRITE "To: "
- SET X=5
- SET X1=13
- DO DAT
- +11 ; EAS*1*222 - Add THAILAND(U.S. OR ROYAL THAI MIL BASE):"THLD", LAOS:"LAOS", CAMBODIA(MIMOT OR KREK,KAMPONG CHAM): "CAMB", GUAM, AMERICAN SAMOA, OR TERRITORIAL WATERS:"GUAM", JOHNSTON ATOLL:"JHST"
- +12 ; This is the Military Service screen within the LTC Co-Pay Test options
- +13 ;S Z=5 D WW W " A/O Exp.: " S X=2,Z1=7,DGLTC=1 D YN W "Reg: " S X=7,Z1=11 D DAT W "Exam: " S X=9,Z1=11 D DAT W "A/O#: " S Z=$P(DGRPX,"^",10),Z1=8 D WW1^DGRPV S Z=$P(DGRPX,"^",13) W $S(Z="K":" DMZ",Z="V":"VIET",1:"")
- +14 NEW EASTYPE
- +15 SET Z=5
- DO WW
- WRITE " A/O Exp.: "
- SET X=2
- SET Z1=7
- SET DGLTC=1
- DO YN
- WRITE "Reg: "
- SET X=7
- SET Z1=11
- DO DAT
- WRITE "Exam: "
- SET X=9
- SET Z1=11
- DO DAT
- WRITE "A/O#: "
- SET Z=$PIECE(DGRPX,"^",10)
- SET Z1=8
- DO WW1^DGRPV
- SET Z=$PIECE(DGRPX,"^",13)
- +16 SET EASTYPE=$SELECT(Z="B":" BWN",Z="K":" DMZ",Z="V":"VIET",Z="O":" OTH",Z="T":"THLD",Z="L":"LAOS",Z="C":"CAMB",Z="G":"GUAM",Z="J":"JHST",1:"")
- +17 WRITE EASTYPE
- +18 ;
- +19 SET Z=6
- DO WW
- WRITE " ION Rad.: "
- SET X=3
- SET Z1=7
- SET DGLTC=1
- DO YN
- WRITE "Reg: "
- SET X=11
- SET Z1=9
- DO DAT
- WRITE "Method: "
- +20 ; EAS*1*222 Modified the RADIATION EXPOSURE METHOD (#2,.3212) to get updated field definitions
- +21 ;S X=$P(DGRPX,"^",12) W $S(X=2:"HIROSHIMA/NAGASAKI",X=3:"ATMOSPHERIC NUCLEAR TESTING",X=4:"H/N AND ATMOSPHERIC TESTING",X=5:"UNDERGROUND NUCLEAR TESTING",X=6:"EXPOSURE AT NUCLEAR FACILITY",X=7:"OTHER",1:"")
- +22 WRITE $$GET1^DIQ(2,DFN,.3212,"E")
- +23 ; end EAS*1*222
- +24 SET DGRPX=DGRP(.322)
- +25 FOR DGX=1,4,7,10
- SET X=DGX
- SET Z=DGX-1/3+7
- DO WW
- if DGX<10
- WRITE " "
- WRITE $SELECT(DGX=1:" Lebanon",DGX=4:" Grenada",DGX=7:" Panama",1:" Gulf War"),": "
- SET Z1=6
- DO YN
- WRITE "From: "
- SET X=DGX+1
- SET Z1=13
- DO DAT
- WRITE "To: "
- SET X=DGX+2
- SET Z1=12
- DO DAT
- +26 SET Z=11
- DO WW
- WRITE " Somalia: "
- SET (DGX,X)=16
- SET Z1=6
- DO YN
- WRITE "From: "
- SET X=17
- SET Z1=13
- DO DAT
- WRITE "To: "
- SET X=18
- SET Z1=12
- DO DAT
- +27 ; Contam name changed to SW Asia Conditions, DG*5.3*688
- +28 SET Z=12
- DO WW
- WRITE " SW Asia Cond: "
- SET X=13
- SET Z1=7
- SET DGLTC=1
- DO YN
- WRITE "Reg: "
- SET X=14
- SET Z1=11
- DO DAT
- WRITE "Exam: "
- SET X=15
- SET Z1=10
- DO DAT
- +29 SET Z=13
- DO WW
- SET X=$PIECE(DGRP(.36),"^",12)
- +30 WRITE " Mil Disab Retirement: ",$SELECT(X=0:"NO",X=1:"YES",1:"")
- +31 SET Z=21
- SET X=$PIECE(DGRP(.36),U,13)
- +32 WRITE " Dischrg Due to Disab: ",$SELECT(X=1:"YES",X=0:"NO",1:"")
- +33 SET Z=14
- DO WW
- WRITE " Dent Inj: "
- SET DGRPX=DGRP(.36)
- SET X=8
- SET Z1=28
- DO YN
- WRITE "Teeth Extracted: "
- SET X=9
- SET Z1=9
- DO YN
- SET DGRPD=0
- IF $PIECE(DGRPX,"^",8)="Y"
- IF $PIECE(DGRPX,"^",9)="Y"
- SET DGRPD=1
- +34 IF DGRPD
- SET I1=""
- FOR I=0:0
- SET I=$ORDER(^DPT(DFN,.37,I))
- if 'I
- QUIT
- SET I1=1
- SET DGRPX=^(I,0)
- DO DEN
- +35 SET DGRPX=DGRP(.322)
- +36 SET Z=15
- DO WW
- WRITE " Yugoslavia: "
- SET (DGX,X)=19
- SET Z1=6
- DO YN
- WRITE "From: "
- SET X=20
- SET Z1=13
- DO DAT
- WRITE "To: "
- SET X=21
- SET Z1=12
- DO DAT
- +37 SET Z=16
- DO WW
- WRITE " Purple Heart: "
- SET DGRPX=DGRP(.53)
- SET X=1
- DO YN
- Begin DoDot:1
- +38 IF $PIECE($GET(DGRPX),U)="Y"
- IF ($PIECE($GET(DGRPX),U,2)]"")
- WRITE ?26,"PH Status: "_$SELECT($PIECE($GET(DGRPX),U,2)="1":"Pending",$PIECE($GET(DGRPX),U,2)="2":"In Process",$PIECE($GET(DGRPX),U,2)="3":"Confirmed",1:"")
- End DoDot:1
- +39 IF $PIECE($GET(DGRPX),U)="N"
- Begin DoDot:1
- +40 SET DGX=$PIECE(DGRPX,U,3)
- +41 SET DGX=$SELECT($GET(DGX)=1:"UNACCEPTABLE DOCUMENTATION",$GET(DGX)=2:"NO DOCUMENTATION REC'D",$GET(DGX)=3:"ENTERED IN ERROR",$GET(DGX)=4:"UNSUPPORTED PURPLE HEART",$GET(DGX)=5:"VAMC",$GET(DGX)=6:"UNDELIVERABLE MAIL",1:"")
- +42 IF $GET(DGX)]""
- WRITE ?26,"PH Remarks: "_$SELECT($GET(DGX)]"":$GET(DGX),1:"")
- End DoDot:1
- +43 ;N/T Radium Treatment expos.
- SET Z=17
- DO WW
- WRITE " N/T Radium: "
- Begin DoDot:1
- +44 NEW DGNT
- SET DGRPX=$$GETCUR^DGNTAPI(DFN,"DGNT")
- WRITE $GET(DGNT("INTRP"))
- IF $GET(DGNT("INTRP"))["YES"
- WRITE "*"
- SET DGLTCEX=1
- End DoDot:1
- Q KILL DGRPD,DGRPSV
- +1 QUIT
- YN SET Z=$SELECT($PIECE(DGRPX,"^",X)="Y":"YES",$PIECE(DGRPX,"^",X)="N":"NO",$PIECE(DGRPX,"^",X)="U":"UNK",1:"")
- if Z="YES"&($GET(DGLTC))
- SET Z=Z_"*"
- SET DGLTCEX=1
- DO WW1^DGRPV
- KILL DGLTC
- QUIT
- DAT SET Z=$PIECE(DGRPX,"^",X)
- IF Z']""
- SET Z=""
- +1 IF '$TEST
- SET Z=$$FMTE^XLFDT(Z,"5DZ")
- +2 DO WW1^DGRPV
- QUIT
- DEN WRITE !?3," Trt Date: "
- SET X=1
- SET Z1=10
- DO DAT
- WRITE "Cond.: ",$EXTRACT($PIECE(DGRPX,"^",2),1,45)
- QUIT
- S ;Service Branch
- NEW DGRPSB
- SET DGRPSB=+$PIECE(DGRPX,U,DGRPSV+1)
- +1 WRITE !?4,$SELECT($DATA(^DIC(23,DGRPSB,0)):$EXTRACT($PIECE(^(0),"^",1),1,15),1:DGRPU)
- if $$FV^DGRPMS(DGRPSB)=1
- WRITE ?20,"("_$PIECE(DGRP(.321),U,14)_")"
- +2 WRITE ?27,$SELECT($PIECE(DGRPX,"^",DGRPSV+4)]"":$PIECE(DGRPX,"^",DGRPSV+4),1:DGRPU)
- +3 FOR I=2,3
- SET X=$PIECE(DGRPX,"^",DGRPSV+I)
- SET X=$SELECT(X]"":$$FMTE^XLFDT(X,"5DZ"),1:"UNKNOWN")
- WRITE ?$SELECT(I=2:46,1:58),X
- +4 WRITE ?70,$SELECT($DATA(^DIC(25,+$PIECE(DGRPX,"^",DGRPSV),0)):$EXTRACT($PIECE(^(0),"^",1),1,9),1:"UNKNOWN")
- QUIT
- MR WRITE !?19,"Receiving Military retirement in lieu of VA Compensation."
- QUIT
- WW ;Write number on screens for display and/or edit (Z=number)
- +1 ; NOTE: This section was copied from WW^DGRPV and modified specifically
- +2 ; for LTC. The code calling ^DGRPV has been redirected here.
- +3 if DGRPW
- WRITE !
- +4 QUIT
- S1 ;Display MSE data from .3216 multiple EAS*1.0*202
- +1 NEW DGMSECNT,DGRPSB
- +2 FOR DGMSECNT=1:1:3
- IF $DATA(DGMSE(DGMSECNT))
- Begin DoDot:1
- +3 SET DGRPSB=$PIECE(DGMSE(DGMSECNT),"^",3)
- +4 WRITE !?4,$SELECT($DATA(^DIC(23,DGRPSB,0)):$EXTRACT($PIECE(^DIC(23,DGRPSB,0),"^",1),1,15),1:DGRPU)
- if $$FV^DGRPMS(DGRPSB)=1
- WRITE ?20,"("_$PIECE(DGRP(.321),U,14)_")"
- +5 WRITE ?27,$PIECE(DGMSE(DGMSECNT),"^",5)
- +6 FOR I=1,2
- SET X=$PIECE(DGMSE(DGMSECNT),"^",I)
- SET X=$SELECT(X]"":$$FMTE^XLFDT(X,"5DZ"),1:"UNKNOWN")
- WRITE ?$SELECT(I=1:46,2:58),X
- +7 WRITE ?70,$SELECT($DATA(^DIC(25,+$PIECE(DGMSE(DGMSECNT),"^",6),0)):$EXTRACT($PIECE(^DIC(25,$PIECE(DGMSE(DGMSECNT),"^",6),0),"^",1),1,9),1:"UNKNOWN")
- +8 QUIT
- End DoDot:1
- +9 QUIT
