source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP6CL.m@ 1606

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1DGRP6CL ;ALB/TMK - REGISTRATION SCREEN 6 FIELDS Conflict locations ; 09/15/2005
2 ;;5.3;Registration;**689,751,764**;Aug 13, 1993;Build 16
3 ;
4CLLST(DFN,DGCONF,DGPOSS,DGMSE) ;
5 ; For patient DFN:
6 ; Returns DGCONF array: DGCONF(conf loc)= Start dt^End dt
7 ; or, for multiple OEF/OIF/ UNKNOWN OEF/OIF: DGCONF(conf loc-ien) =
8 ; Start dt ^ End dt ^ Site source ^ Lock flag
9 ; DGCONF(conflict loc,1)=1 if dts inconsistent w/mse dts
10 ; DGPOSS = array of possible conflict locations, based on service
11 ; episode dts DGPOSS(conf loc)=""
12 ; DGMSE = array of military svc episodes
13 ; DGMSE(1-3)=fr dt^to dt^branch ien^comp code
14 ;
15 N DGZ,DGZ0,DGZ1,DG32,DG3291,DIQUIET,FRTO
16 S DIQUIET=1 K DGCONF,DGPOSS
17 S DG32=$G(^DPT(DFN,.32)),DG3291=$G(^(.3291))
18 S DGZ1=0
19 F DGZ=1:1:3 S DGZ0=$S(DGZ=1:"5^5^6^7",DGZ=2:"19^10^11^12",1:"20^15^16^17") D
20 . Q:$S($P(DG32,U,+DGZ0)="Y":0,1:'$P(DG32,U,+DGZ0))
21 . S DGZ1=DGZ1+1,DGMSE(DGZ1)=$P(DG32,U,$P(DGZ0,U,3))_U_$P(DG32,U,$P(DGZ0,U,4))_U_$P(DG32,U,$P(DGZ0,U,2))_U_$P(DG3291,U,DGZ)
22 ;
23 ; Must chk all possible/on-file conf locs for valid mil svc pd
24 ; Extract OEF/OIF data
25 F DGZ="OEF","OIF","UNK" S DGCONF(DGZ)=""
26 D GET^DGENOEIF(DFN,.DGZ,0,"","")
27 S DGZ0=0 F S DGZ0=$O(DGZ("IEN",DGZ0)) Q:'DGZ0 S DGZ=$G(DGZ("IEN",DGZ0)) D
28 . N DGCONFX
29 . Q:'$G(DGZ("FR",DGZ0))&'$G(DGZ("TO",DGZ0))
30 . S DGCONFX=$P("OIF^OEF^UNK",U,+$G(DGZ("LOC",DGZ0)))_"-"_DGZ,DGCONF=DGCONFX,DGCONF($P(DGCONFX,"-"))=$G(DGCONF($P(DGCONFX,"-")))_DGZ_";"
31 . F FRTO=1,0 S $P(DGCONF(DGCONFX),U,$S(FRTO:1,1:2))=$$GETDT^DGRPMS(DFN,DGCONFX,FRTO) I FRTO=0 D CKDT^DGRP6CL1(.DGCONF,.DGMSE,.DGPOSS)
32 . S $P(DGCONF(DGCONFX),U,3)=$G(DGZ("SITE",DGZ0))
33 . S $P(DGCONF(DGCONFX),U,4)=$G(DGZ("LOCK",DGZ0))
34 F DGCONF="OEF","OIF","UNK" D CKDT^DGRP6CL1(.DGCONF,.DGMSE,.DGPOSS)
35 F DGCONF="VIET","LEB","GREN","PAN","GULF","SOM","YUG" F FRTO=1,0 S $P(DGCONF(DGCONF),U,$S(FRTO:1,1:2))=$$GETDT^DGRPMS(DFN,DGCONF,FRTO) I FRTO=0 D CKDT^DGRP6CL1(.DGCONF,.DGMSE,.DGPOSS)
36 Q
37 ;
38YN(DGRPX,X) ;Format Yes/No fld in $P(DGRPX,U,X)
39 Q $S($P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N":"NO ",$P(DGRPX,"^",X)="U":"UNK",1:" ")
40 ;
41DAT(DGRPX,X,Z1) ; Format dt in $P(DGRPX,U,X) for a length of Z1
42 N Z
43 S Z=$P(DGRPX,U,X)
44 I Z'="" S Z=$$FMTE^XLFDT(Z,"5DZ")
45 S:$L(Z)<Z1 Z=$E(Z_$J("",Z1),1,Z1)
46 Q Z
47 ;
48EN(DFN,QUIT) ; Entry from reg screen 6
49 N DIPA,DGCONF,DGCONFS,DGCONF1,DGMSE,DGMSG,DGPOSS,DIR,DIE,DR,DA
50 ;
51 ; Return QUIT=1 if ^ entered
52EN1 ; Entry from conf subscreen off reg screen 6
53 ; Routine loops until exit/quit from subscreen
54 D CLEAR^VALM1
55 K DGCONF,DGCONFS,DGPOSS,DGMSE,DGMSG,DGDISP
56 N DIR,DTOUT,DUOUT,Z,Z0,Z1,Z2,X,Y,LOOP,DG,DGM,DGZ,DGEG,DGEGS,DGX,DGX1,DG321,DG322,DGCT,DGY,DGY1,DGCTX,SSN
57 D CLLST(DFN,.DGCONF,.DGPOSS,.DGMSE)
58 I $G(DGRPV) S $E(DGRPVV(6),2,3)="00",DGRPVV(6,"NOEDIT")=1
59 I '$G(DGRPV),$E(DGRPVV(6),2,3)="11" S $E(DGRPVV(6),2,3)="00",DGRPVV(6,"NOEDIT")=1
60 S DGMSG=0,DGCTX=0
61 F Z="OEF","OIF","UNK" D ; Sort OEF/OIF/ UNKNOWN OEF/OIF
62 . ; by reverse from dt within each conf
63 . S Z0=Z F S Z0=$O(DGCONF(Z0)) Q:Z0=""!(Z0'[Z) S Z2=Z_"-"_(9999999-DGCONF(Z0)) S DGCONFS(Z2)=$P(Z0,"-",2) I 'DGMSG,$G(DGCONF(Z0,1)) S DGMSG=1
64 S DG321=$G(^DPT(DFN,.321)),DG322=$G(^(.322))
65 ;
66 S DIR(0)="SA^",DGCT=0
67 S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
68 S DGCT=DGCT+1,DIR("A",DGCT)=$$SSNNM^DGRPU(DFN)
69 S DGCT=DGCT+1,DIR("A",DGCT)="",$P(DIR("A",DGCT),"=",81)=""
70 S DGCT=DGCT+1,DIR("A",DGCT)=$S($O(DGMSE(0)):"MILITARY SERVICE PERIODS:",1:"NO SERVICE PERIODS FOR THIS PATIENT - NO CONFLICT LOC CAN BE ENTERED")
71 S Z=0 F S Z=$O(DGMSE(Z)) Q:'Z D
72 . S DGCT=DGCT+1,DIR("A",DGCT)=$J("",3)_$E($$EXTERNAL^DILFD(2,.325,"",$P(DGMSE(Z),U,3))_$S($P(DGMSE(Z),U,4)'="":"/"_$$SVCCOMP($P(DGMSE(Z),U,4)),1:"")_$J("",30),1,30)
73 . S DIR("A",DGCT)=DIR("A",DGCT)_" ("_$S($P(DGMSE(Z),U):$$FMTE^XLFDT($P(DGMSE(Z),U),"5DZ"),1:"missing")_"-"_$S($P(DGMSE(Z),U,2):$$FMTE^XLFDT($P(DGMSE(Z),U,2),"5DZ"),1:"missing")_")"
74 S DGCT=DGCT+1,DIR("A",DGCT)=" "
75 S DGCT=DGCT+1,DIR("A",DGCT)=$J("",24)_"---- CONFLICT LOCATIONS ----"
76 S DGCT=DGCT+1,DIR("A",DGCT)=$J("",34)_"FROM"_$J("",9)_"TO"_$J("",7)_"SOURCE (FOR OEF/OIF)"
77 ; DGCONF(DGCONF,"OK")=# entries for OEF/OIF/ UNKNOWN OEF/OIF
78 ; that are site-entered
79 ; DGCONF(DGCONF,"OK",entry ien)=display #^formatted from dt^
80 ; formatted to dt^inconsistent flag (valid entries for editing)
81 S DGEG=0
82 F DGEGS=2,1,3 D
83 . S DGCONF=$P("OIF^OEF^UNK",U,DGEGS),DGM=0
84 . S DG=$$ISVALID^DGRP6CL2(.DGCONF,.DGPOSS)
85 . S DGEG=DGEG+1
86 . S DGDISP=$S(DGCONF'="UNK":$J("",8),1:"OEF/OIF ")_DGCONF_": "
87 . S DGCT=DGCT+1,DGCTX=DGCT S DIR("A",DGCT)=" "_$E(DG,1)_DGEG_$E(DG,2)_" -"_DGDISP_$$YN($S(DGCONF(DGCONF):"Y",'$D(^DPT(DFN,.3215,0)):"",1:"N"),1)
88 . I $G(DGCONF(DGCONF))!$D(DGPOSS(DGCONF)) I '$G(DGRPV),$G(DGCONF(DGCONF,"VEDIT"))'=2,'$G(DGCONF(DGCONF,"NOEDIT")) S:DGCONF'="UNK" DIR(0)=DIR(0)_DGEG_":"_DGCONF_";"
89 . S (DGZ,DGCONFS)=DGCONF F S DGCONFS=$O(DGCONFS(DGCONFS)) Q:DGCONFS=""!(DGCONFS'[DGZ) D
90 .. N DGUN,DGIEN,STA
91 .. S DGIEN=DGCONFS(DGCONFS),DGCONF=DGZ_"-"_DGIEN,DGCONF1=DGZ,DGM=DGM+1
92 .. I $G(DGCONF(DGCONF,1)),DGCTX S $E(DIR("A",DGCTX),1,3)="***"
93 .. S DG=$$ISVALID^DGRP6CL2(.DGCONF,.DGPOSS)
94 .. S DGUN=$S($G(DGCONF(DGCONF,"NOEDIT")):1,1:0)
95 .. I 'DGUN S DGCONF(DGCONF1,"OK")=$G(DGCONF(DGCONF1,"OK"))+1,DGCONF(DGCONF1,"OK",DGIEN)=DGM_U_$$FMTE^XLFDT($P(DGCONF(DGCONF),U),"5DZ")_U_$$FMTE^XLFDT($P(DGCONF(DGCONF),U,2),"5DZ")
96 .. I DGM>1 S DGCT=DGCT+1
97 .. S DIR("A",DGCT)=$S(DGM>1:$J("",27-$L(DGM)),1:DIR("A",DGCT)_" ")_"("_DGM_") "_$E($$DAT(DGCONF(DGCONF),1,13)_$J("",12),1,12)_$E($$DAT(DGCONF(DGCONF),2,11)_$J("",10),1,10)_" "
98 .. S STA=$P(DGCONF(DGCONF),U,3)
99 .. S:STA STA=$P($G(^DIC(4,+STA,99)),U)
100 .. S DIR("A",DGCT)=DIR("A",DGCT)_$S($P(DGCONF(DGCONF),U,3)="CEV":"",1:"Station #")_$E(STA_$J("",$S('DGUN:6,1:3)),1,$S('DGUN:6,1:3))
101 .. I DGUN S DIR("A",DGCT)=DIR("A",DGCT)_" (No Edit)"
102 D LOOPCNF^DGRP6CL1(.DGCONF,.DGPOSS,.DIR)
103 S DGCT=DGCT+1,DIR("A",DGCT)=" "
104 I $G(DGMSG) S DGCT=DGCT+1,DIR("A",DGCT)="*** ==>OEF/OIF Dates are inconsistent with veteran's military service episodes"
105 S DIR("A")="SELECT THE NUMBER OF A CONFLICT LOCATION OR (Q)UIT: "
106 S DIR(0)=DIR(0)_"Q:QUIT"
107 S DIR("?")="^D HELP^DGRP6CL1($P(DIR(0),U,2))"
108 S DIR("B")="QUIT"
109 D ^DIR K DIR
110 I $D(DUOUT)!$D(DTOUT)!(Y="Q") S:Y'="Q" QUIT=1 G QUIT
111 S DGY=Y,DGY1=$S(Y=2:1,Y=1:2,1:Y)
112 I DGY<4 S DGCONF=""
113 I DGY'<4 D
114 . S DGCONF=$P("OEF^OIF^UNK^VIET^LEB^GREN^PAN^GULF^SOM^YUG",U,DGY)
115 . I $G(DGCONF(DGCONF,1)) W !!,"WARNING - THIS CONFLICT IS INCONSISTENT WITH MILITARY SERVICE DATA",!
116 . S DIE=2,DA=DFN,DR=$P($T(@DGCONF),";;",2) D:DR'="" ^DIE K DIE,DA,DR
117 I DGY=1!(DGY=2) D
118 . S DGCONF=$P("OEF^OIF",U,DGY)
119 . I '$G(DGCONF(DGCONF,"OK")),$G(DGCONF(DGCONF,"VEDIT"))'=2 D ADDCFL^DGRP6CL1(DFN,DGY1,DGCONF) Q ; Add new only valid action
120 . I $G(DGCONF(DGCONF,"VEDIT"))=1 S DIR("A")="DO YOU WANT TO (A)DD OR (E)DIT "_DGCONF_" CONFLICT DATA?: ",DIR(0)="SA^A:ADD;E:EDIT",DIR("B")="ADD" D ^DIR K DIR
121 . I $G(DGCONF(DGCONF,"VEDIT"))=2,$G(DGCONF(DGCONF,"OK")) S DIR("A")="DO YOU WANT TO EDIT "_DGCONF_" CONFLICT DATA?: ",DIR(0)="YA",DIR("B")="YES" D ^DIR K DIR S Y=$S(Y=1:"E",1:Y)
122 . Q:$D(DTOUT)!$D(DUOUT)
123 . I Y="A" D ADDCFL^DGRP6CL1(DFN,DGY1,DGCONF) Q
124 . I Y="E" D
125 .. N DGXREF,IEN,DIR,X,Y
126 .. I DGCONF(DGCONF,"OK")=1 S IEN=+$O(DGCONF(DGCONF,"OK",0)) I IEN D EDCFL^DGRP6CL1(DFN,IEN,$G(DGCONF(DGCONF,"VEDIT"))) Q
127 .. S DIR(0)="SA^",DIR("A")="SELECT THE # OF THE "_DGCONF_" CONFLICT PERIOD TO EDIT: ",DIR("A",1)=" "
128 .. S Z=0 F S Z=$O(DGCONF(DGCONF,"OK",Z)) Q:'Z S Z0=DGCONF(DGCONF,"OK",Z),DIR(0)=DIR(0)_+Z0_":"_$P(Z0,U,2)_$S($P(Z0,U,3)'="":"-"_$P(Z0,U,3),1:"")_";",DGXREF(+Z0)=Z
129 .. S DIR(0)=DIR(0)_"Q:QUIT"
130 .. D ^DIR K DIR
131 .. I Y D EDCFL^DGRP6CL1(DFN,+$G(DGXREF(+Y)),$G(DGCONF(DGCONF,"VEDIT")))
132 G EN1
133 ;
134QUIT Q
135 ;
136EN2 ; Consistency checker re-edit entrypoint for OEF/OIF data
137 N DGOEIF,DGZ,DGQUIT,Z,Z0,Y
138 D GET^DGENOEIF(DFN,.DGOEIF,2,"",1)
139 I $G(DGOEIF("COUNT"))&($O(DGOEIF("OIF",0))!$O(DGOEIF("OEF",0))) D
140 . F Z="OEF","OIF" S Z0=0 F S Z0=$O(DGOEIF(Z,Z0)) Q:'Z0 I $G(DGOEIF(Z,Z0,"IEN")) S DGZ(DGOEIF(Z,Z0,"IEN"))=""
141 . S (DGQUIT,DGZ)=0 F S DGZ=$O(DGZ(DGZ)) Q:'DGZ D Q:DGQUIT
142 .. N DGX,DA,DIE,DR,X
143 .. S DGX=$G(^DPT(DFN,.3215,DGZ,0))
144 .. W !!,"OEF/OIF CONFLICT: ",$$EXTERNAL^DILFD(2.3215,.01,"",$P(DGX,U))," FROM: "_$$EXTERNAL^DILFD(2.3215,.02,"",$P(DGX,U,2))," TO: "_$$EXTERNAL^DILFD(2.3215,.03,"",$P(DGX,U,3))
145 .. S DA=DGZ,DA(1)=DFN,DIE="^DPT("_DA(1)_",.3215,",DR=".01;.02R;.03R" D ^DIE I $D(Y) S DGQUIT=1
146 Q
147 ;
148SVCCOMP(X) ; Returns display text for service component
149 Q $S(X="R":"REGULAR",X="V":"RESERVE",X="G":"GUARD",1:"")
150 ;
151VIET ;;.32101//NO;S:X'="Y" Y="@64";.32104;.32105;@64;
152LEB ;;.3221//NO;S:X'="Y" Y="@67";.3222;Q;.3223;@67;
153GREN ;;.3224//NO;S:X'="Y" Y="@68";.3225;Q;.3226;@68;
154PAN ;;.3227//NO;S:X'="Y" Y="@69";.3228;Q;.3229;@69;
155GULF ;;.32201//NO;S:X'="Y" Y="@610";.322011;Q;.322012;@610;
156SOM ;;.322016//NO;S:X'="Y" Y="@611";.322017;Q;.322018;@611;
157YUG ;;.322019//NO;S:X'="Y" Y="@615";.32202;Q;.322021;@615;
158OEF ;;
159OIF ;;
160UNK ;;
161 ;;
Note: See TracBrowser for help on using the repository browser.