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 Sep 23, 2025@19:30:14 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
