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

Last change on this file since 841 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.2 KB
Line 
1EASECSC1 ;ALB/PHH,LBD,EG - LTC Co-Pay Test Screen Military Service ; 05/06/2006 4:17 PM
2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,38,62,75**;Mar 15, 2001;Build 7
3 ;
4 ; Input -- DFN Patient IEN
5 ; DGMTACT LTC Co-Pay Test Action
6 ; DGVINI Veteran Individual Annual Income IEN
7 ; DGVIRI Veteran Income Relation IEN
8 ; DGVPRI Veteran Patient Relation IEN
9 ; Output -- None
10 ;
11EN ;Entry point
12 N DGLTCEX,DGLTC,IORVON,IORVOFF
13 D ^DGRPV
14 D EASECRP6
15 S X="IORVON;IORVOFF" D ENDR^%ZISS K X
16 I $G(DGLTCEX) W !?2,$G(IORVON)," * VETERAN MAY BE EXEMPT FROM COPAY IF LTC EPISODE IS DUE TO THIS CONDITION.",$G(IORVOFF)
17 S X="^2"
18 S:$$PAUSE(0) X="^"
19 G EN1^EASECSCR
20 Q
21PAUSE(RESP) ; Prompt user for next page or quit
22 N DIR,DIRUT,DUOUT,DTOUT,U,X,Y
23 S DIR(0)="E"
24 D ^DIR
25 I 'Y S RESP=1
26 Q RESP
27 ;
28EASECRP6 ; Display the screen
29 ; Note: This section was copied from ^DGRP6 and modified specifically
30 ; to work with LTC.
31 ;
32 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:"")
33 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"
34 W !?4,"--------------",?27,"---------",?46,"-------",?58,"---------",?70,"---------"
35 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
36 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:"")
37 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:"")
38 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
39 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:"")
40 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: "
41 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:"")
42 S DGRPX=DGRP(.322)
43 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
44 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
45 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
46 S Z=13 D WW S X=$P(DGRP(.36),"^",12)
47 W " Mil Disab Retirement: ",$S(X=0:"NO",X=1:"YES",1:"")
48 S Z=21 S X=$P(DGRP(.36),U,13)
49 W " Dischrg Due to Disab: ",$S(X=1:"YES",X=0:"NO",1:"")
50 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
51 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
52 S DGRPX=DGRP(.322)
53 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
54 S Z=16 D WW W " Purple Heart: " S DGRPX=DGRP(.53),X=1 D YN D
55 . 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:"")
56 I $P($G(DGRPX),U)="N" D
57 . S DGX=$P(DGRPX,U,3)
58 . 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:"")
59 . I $G(DGX)]"" W ?26,"PH Remarks: "_$S($G(DGX)]"":$G(DGX),1:"")
60 S Z=17 D WW W " N/T Radium: " D ;N/T Radium Treatment expos.
61 . N DGNT S DGRPX=$$GETCUR^DGNTAPI(DFN,"DGNT") W $G(DGNT("INTRP")) I $G(DGNT("INTRP"))["YES" W "*" S DGLTCEX=1
62Q K DGRPD,DGRPSV
63 Q
64YN 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
65DAT S Z=$P(DGRPX,"^",X) I Z']"" S Z=""
66 E S Z=$$FMTE^XLFDT(Z,"5DZ")
67 D WW1^DGRPV Q
68DEN W !?3," Trt Date: " S X=1,Z1=10 D DAT W "Cond.: ",$E($P(DGRPX,"^",2),1,45) Q
69S N DGRPSB S DGRPSB=+$P(DGRPX,U,DGRPSV+1) ;Service Branch
70 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)_")"
71 W ?27,$S($P(DGRPX,"^",DGRPSV+4)]"":$P(DGRPX,"^",DGRPSV+4),1:DGRPU)
72 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
73 W ?70,$S($D(^DIC(25,+$P(DGRPX,"^",DGRPSV),0)):$E($P(^(0),"^",1),1,9),1:"UNKNOWN") Q
74MR W !?19,"Receiving Military retirement in lieu of VA Compensation." Q
75WW ;Write number on screens for display and/or edit (Z=number)
76 ; NOTE: This section was copied from WW^DGRPV and modified specifically
77 ; for LTC. The code calling ^DGRPV has been redirected here.
78 W:DGRPW !
79 Q
Note: See TracBrowser for help on using the repository browser.