source: WorldVistAEHR/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASECSC1.m@ 1800

EASECSC1 ;ALB/PHH,LBD,EG - LTC Co-Pay Test Screen Military Service ; 05/06/2006 4:17 PM
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,38,62,75**;Mar 15, 2001;Build 7
 ;
 ; 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,"---------"
 S DGRPX=DGRP(.32),DGRPSV=4 D S I $P(DGRPX,"^",19)="Y" S DGRPSV=9 D S I $P(DGRPX,"^",20)="Y" S DGRPSV=14 D S
 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
 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:"")
 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: "
 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:"")
 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
 S Z=12 D WW W "    Env Contam: " 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