Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPE.m

    r613 r623  
    1 DGRPE   ;ALB/MRL,LBD,BRM,TMK - REGISTRATIONS EDITS ;1/27/07  13:11
    2         ;;5.3;Registration;**32,114,139,169,175,247,190,343,397,342,454,415,489,506,244,547,522,528,555,508,451,626,638,624,677,672,702,689,735,634**;Aug 13, 1993;Build 30
    3         ; Modified from FOIA VISTA,
    4         ; Copyright (C) 2007 WorldVistA
    5         ;
    6         ; This program is free software; you can redistribute it and/or modify
    7         ; it under the terms of the GNU General Public License as published by
    8         ; the Free Software Foundation; either version 2 of the License, or
    9         ; (at your option) any later version.
    10         ;
    11         ;
    12         ; VOE changes: DAOU,VA/CJS,WV/TOAD 5/9/2006
    13         ; conditionally add edit fields to the following lines:
    14         ;    201: Is Patient a Veteran (19902), Interpreter Language (19906)
    15         ;    202: skip line if agency code for IHS or VOE
    16         ; 305002+1: for VOE, Mother's Country of Birth (19903), Father's Country
    17         ;         of Birth (19904), Year Arrived in U.S. (19905)
    18         ;
    19         ;DGDR contains a string of edits; edit=screen*10+item #
    20         ;
    21         ;line tag screen*10+item*1000 = continuation line
    22         ;
    23         I DGRPS=1,DGDR["101," D CEDITS^DGRPECE(DFN)
    24         I DGRPS=8 D ^DGRPEIS,Q Q  ; family demographic edit...not conventional!!  :)
    25         I DGRPS=9 D EDIT9^DGRPEIS2,Q Q  ; income screening data ($$$)
    26         I DGRPS=5,DGDR["501," D
    27         .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q
    28         .D REG^IBCNBME(DFN)
    29         .Q
    30         N QUIT S QUIT=0
    31         I DGRPS=6,$S(DGDR["602,"!(DGDR["603,"):1,1:0) D  I QUIT D Q Q  ;Screen 6 subscreens
    32         . I DGDR["601," D  Q:QUIT
    33         .. D SETDR("601,",.DR)
    34         .. S (DA,Y)=DFN,DIE="^DPT("
    35         .. D ^DIE I $D(Y) S QUIT=1
    36         .. S DGDR=$P(DGDR,"601,",1)_$P(DGDR,"601,",2,999)
    37         . I DGDR["602," D EN^DGRP6CL(DFN,.QUIT)  Q:QUIT  ; Conflicts
    38         . I DGDR["603," D EN^DGRP6EF(DFN,.QUIT)  Q:QUIT  ; Exposures
    39         ;-- Tricare screen #15
    40         I DGRPS=15 D EDIT^DGRP15,Q Q
    41         ;
    42         N DGPH,DGPHFLG
    43         K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
    44         G ^DGRPE1:DGRPS>6
    45         I DGRPS=4 D ^DGRPE4
    46         D SETDR(DGDR,.DR)
    47         S (DA,Y)=DFN,DIE="^DPT("
    48         D ^DIE
    49         ;check for Combat Vet status
    50         I $G(DGCVFLG)=1,($P($$CVEDT^DGCV(DFN),U,2)']"") D
    51         . W !!,"**NOTE-Change(s) made in this session deleted the veteran's Combat Vet status!"
    52         . S DIR(0)="EA" D ^DIR K DIR
    53         I $G(DGPHFLG)>0 D EDITPH1^DGRPLE()
    54 Q       K DA,DIE,DR,DGCT,DGCVFLG,DGDR,DGDRD,DGDRS,DGRPADI,I,J,J1,DGCOMLOC,DIPA
    55         Q
    56         ;
    57 SETDR(DGDR,DR)  ; Set up DR string(s) for edit groups selected
    58         N DGCT,DGDRS,J1,J2
    59         K DR S DR="",DGDRS="DR",DGCT=0
    60         F I=1:1 S J=$P(DGDR,",",I) Q:J=""  S J1=J D:$T(@J1)
    61         . S DGDRD=$P($T(@J1),";;",2) D S
    62         . N J2
    63         . F J2=0:1 S J1=J*1000+J2 Q:'$T(@J1)  S DGDRD=$P($T(@J1),";;",2) D S
    64         Q
    65         ;
    66 S       I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
    67         S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q
    68         Q
    69         ;
    70         ; VOE changes at lines 201, 202, 304 & after 305002
    71         ;
    72 SETFLDS(DGDR)   ; Set up fields to edit
    73         Q
    74         ;
    75 101     ;;
    76 102     ;;1;
    77 103     ;;.091;
    78 104     ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);
    79 105     ;;.12105//NO;S:X="N" Y="@15" S:X="Y" DIE("NO^")="";.1217;I X']"" W !?4,$C(7),"But I need a Start Date for this Temporary Address." S Y=.12105;.1218;.1211;I X']"" W !?4,$C(7),"But I need at least one line of a Temporary address." S Y=.12105;
    80 105000  ;;.1212;S:X']"" Y=.1214;.1213:.1215;.12112;Q;.12111;.1219;@15;K DIE("NO^");
    81 109     ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);.02;D DR109^DGRPE;6;2;K DR(2,2.02),DR(2,2.06);.05;.08;K DIE("NO^");
    82 111     ;;.14105//NO;S:X="N" Y="@111" S:X="Y" DIE("NO^")="";.1417;I X']"" W !?4,$C(7),"But I need a Start Date." S Y=.14105;.1418;D DR111^DGRPE;.141;I '$P($$CAACT^DGRPCADD(DFN),U,2) W !?4,"But I need at least one active category." S Y=.14105;
    83 111000  ;;K DR(2,2.141);.1411;I X']"" W !?4,$C(7),"I need at least one line of Address." S Y=.14105;.1412;S:X']"" Y=.1414;.1413;.1414;.1415;.1416;Q;.14111;@111;K DIE("NO^");
    84 112     ;;.134;.135;.133
    85 201     ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE;;S:$G(DUZ("AG"))'="E" Y="@21";19902;19906;@21
    86 202     ;;S:"IE"[$G(DUZ("AG")) Y="@22";1010.15//NO;S:X'="Y" Y="@22";S DIE("NO^")="";1010.152;I X']"" W !?4,*7,"But I need to know where you were treated most recently." S Y=1010.15;1010.151;1010.154;S:X']"" Y="@22";1010.153;@22;K DIE("NO^");
    87 203     ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06);
    88 205     ;;.181;
    89 301     ;;.211;S:X']"" Y="@31";.212;.2125//NO;I X="Y" S DGADD=".21" D AD^DGRPE S Y=.21011;.213;S:X']"" Y=.216;.214;S:X']"" Y=.216;.215:.217;.2207;.219;.21011;@31;
    90 302     ;;.2191;S:X']"" Y="@32";.2192;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y=.211011;
    91 302000  ;;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195:.2197;.2203;.2199;.211011;@32;
    92 303     ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@33";.3305//NO;I X="Y" S Y="@34",DGX1=1 S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7);@33;.331;S:X']"" DGX1=2,Y="@34";.332;@34;
    93 303000  ;;S:$G(DGX1) Y="@341";.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335:.337;.2201;.339;.33011;S DGX1=2;@341;
    94 303001  ;;S:$G(DGX1)=2 Y="@35";S DGX2=$G(^DPT(DA,.21));.331///^S X=$P(DGX2,U);.332///^S X=$P(DGX2,U,2);.333////^S X=$P(DGX2,U,3);.334///^S X=$P(DGX2,U,4);@35;
    95 303002  ;;S:$G(DGX1)=2 Y="@351";.335///^S X=$P(DGX2,U,5);.336///^S X=$P(DGX2,U,6);.337///^S X=$P(DGX2,U,7);.338///^S X=$P(DGX2,U,8);.339///^S X=$P(DGX2,U,9);.33011///^S X=$P(DGX2,U,11);@351;K DGX1,DGX2;
    96 304     ;;.3311;S:X']"" Y="@36";.3312;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315:.3317;.2204;.3319;.331011;@36;       
    97 305     ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@37";.3405//NO;I X="Y" S DGX1=1,Y="@371" S:$D(^DPT(DFN,.22)) $P(^(.22),U,2)=$P(^(.22),U,7);@37;.341;S:X']"" DGX1=2,Y="@371";.342;@371;
    98 305000  ;;S:$G(DGX1) Y="@38";.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345:.347;.2202;.349;.34011;S DGX1=2;@38;
    99 305001  ;;S:$G(DGX1)=2 Y="@381";S DGX2=$G(^DPT(DA,.21));.341///^S X=$P(DGX2,U);.342///^S X=$P(DGX2,U,2);.343///^S X=$P(DGX2,U,3);.344///^S X=$P(DGX2,U,4);@381
    100 305002  ;;S:$G(DGX1)=2 Y="@39";.345///^S X=$P(DGX2,U,5);.346///^S X=$P(DGX2,U,6);.347///^S X=$P(DGX2,U,7);.348///^S X=$P(DGX2,U,8);.349///^S X=$P(DGX2,U,9);.34011///^S X=$P(DGX2,U,11);@39;K DGX1,DGX2;
    101         ;;S:$G(DUZ("AG"))'="E" Y="@36";19903;19904;19905;@36401 ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;
    102 401     ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;
    103 402     ;;.2514;.2515;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@42" S:(X'=5) Y=.251;.2516;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42;
    104 501     ;;
    105 502     ;;.381;.382///NOW;
    106 503     ;;.383;
    107 601     ;;@60101;D SET32^DGRPE(DA,.DIPA,1);.325;S DIPA("X1")=X S:X="" Y="@60199" I X'="" S:$$FV^DGRPMS(X)'=1 Y="@60111";.3214;I X="" D PRF^DGRPE S Y="@60101";S Y="@6011";
    108 601000  ;;@60111;D:DIPA("X1")'="" WARN32^DGRPE(DIPA("X1"),.DIPA,1,.Y);.32911;@6011;.328;.326;.327;.324;.3285//NO;S:X'="Y" Y="@60199";
    109 601001  ;;@60102;D SET32^DGRPE(DA,.DIPA,2);.3291;S DIPA("X2")=X S:X="" Y="@60199" I X'="" S:$$FV^DGRPMS(X)'=1 Y="@60112";.3214;I X="" D PRF^DGRPE S Y="@60102";S Y="@6012";
    110 601002  ;;@60112;D:DIPA("X2")'="" WARN32^DGRPE(DIPA("X2"),.DIPA,2,.Y);.32912;@6012;.3294;.3292;.3293;.329;.32945//NO;S:X'="Y" Y="@60199";
    111 601003  ;;@60103;D SET32^DGRPE(DA,.DIPA,3);.3296;S DIPA("X3")=X S:X="" Y="@60199" I X'="" S:$$FV^DGRPMS(X)'=1 Y="@60113";.3214;I X="" D PRF^DGRPE S Y="@60103";S Y="@6013";
    112 601004  ;;@60113;D:DIPA("X3")'="" WARN32^DGRPE(DIPA("X3"),.DIPA,3,.Y);.32913;@6013;.3299;.3297;.3298;.3295;@60199;
    113 602     ;;Q;
    114 603     ;;Q;
    115 604     ;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62;
    116 605     ;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63;
    117 606     ;;I $P($G(^DPT(DFN,.361)),U,3)="H" S Y="@6131";.3602//NO;.3603//NO;S Y="@6132";@6131;.3602;.3603;@6132;
    118 607     ;;.368//NO;.369//NO;I $S('$D(^DPT(DA,.36)):1,$P(^(.36),U,8)="Y"!($P(^(.36),U,9)="Y"):0,1:1) S Y="@614";.37;@614;
    119 608     ;;S DGPHFLG=0;.531;S:X'="Y" DGX=X,Y="@616";.532///^S X="PENDING";S Y="@6161";@616;S:DGX'="N" Y="@6162";.533///^S X="VAMC";@6161;S DGPHFLG=1;.535///^S X=$$DIV^DGRPLE();@6162;
    120 AD      N DGZ4,DGPC
    121         S X=$S($D(^DPT(DA,.11)):^(.11),1:""),DGZ4=$P(X,U,12),DGPHONE=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(DGADD)):^(DGADD),1:""),^(DGADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_DGPHONE_U_$P(Y,U,10)
    122         I DGZ4 S DGPC=$S((DGADD=.33):1,(DGADD=.34):2,(DGADD=.211):3,(DGADD=.331):4,(DGADD=.311):5,(DGADD=.25):6,(DGADD=.21):7,1:0) S:DGPC $P(^DPT(DFN,.22),U,DGPC)=DGZ4
    123         K DGADD,DGPHONE Q
    124 DR109   ;Drop through (use same logic as DR203)
    125 DR203   S DR(2,2.02)=".01RACE;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.02,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2031"";.02;@2031;"
    126         S DR(2,2.06)=".01ETHNICITY;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.06,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2032"";.02;@2032;"
    127         Q
    128 DR111   ;Set DR string for Confidential Address categories
    129         S DR(2,2.141)=".01;1//YES;"
    130         Q
    131 PRF     ; Write Proof needed for FV
    132         W !?4,$C(7),"Proof is required for Filipino vet."
    133         Q
    134         ;
    135 SET32(DA,DIPA,SEQ)      ; Extract the .32 node from patient file and set DIPA
    136         ; array with the BOS and component data for the SEQ military service
    137         ; episode (1-3)
    138         N I,Q,Z
    139         K DIPA(32,SEQ)
    140         S Q=$G(^DPT(DA,.32)),Z=$G(^(.3291))
    141         S DIPA(32,SEQ)=$P(Q,U,SEQ*5)_U_$P(Z,U,SEQ),DIPA("X"_SEQ)=$P(DIPA(32,SEQ),U)
    142         Q
    143         ;
    144 WARN32(X,DIPA,SEQ,Y)    ; Warn if the BOS is changed, then the component will
    145         ; be deleted
    146         ; Returns Y to skip component if the component should not be asked
    147         ;   for this branch of service
    148         N Z
    149         I '$$CMP(X) S Y="@601"_SEQ
    150         S Z=$G(DIPA(32,SEQ))
    151         Q:$S($P(Z,U,2)=""!($P(Z,U)=""):1,1:$P(Z,U)=X)
    152         ;
    153         I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",!
    154         Q
    155         ;
    156 CMP(X)  ; Function to determine if service component is valid for
    157         ; branch of service ien in X   0 = invalid  1 = valid 
    158         ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS
    159         Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0)
    160         ;
     1DGRPE ;ALB/MRL,LBD,BRM,TMK - REGISTRATIONS EDITS ;1/27/07  13:11
     2 ;;5.3;Registration;**32,114,139,169,175,247,190,343,397,342,454,415,489,506,244,547,522,528,555,508,451,626,638,624,677,672,702,689,735,634**;Aug 13, 1993;Build 28
     3 ; Modified from FOIA VISTA,
     4 ; Copyright (C) 2007 WorldVistA
     5 ;
     6 ; This program is free software; you can redistribute it and/or modify
     7 ; it under the terms of the GNU General Public License as published by
     8 ; the Free Software Foundation; either version 2 of the License, or
     9 ; (at your option) any later version.
     10 ;
     11 ;
     12 ; VOE changes: DAOU,VA/CJS,WV/TOAD 5/9/2006
     13 ; conditionally add edit fields to the following lines:
     14 ;    201: Is Patient a Veteran (19902), Interpreter Language (19906)
     15 ;    202: skip line if agency code for IHS or VOE
     16 ; 305002+1: for VOE, Mother's Country of Birth (19903), Father's Country
     17 ;         of Birth (19904), Year Arrived in U.S. (19905)
     18 ;
     19 ;DGDR contains a string of edits; edit=screen*10+item #
     20 ;
     21 ;line tag screen*10+item*1000 = continuation line
     22 ;
     23 I DGRPS=1,DGDR["101," D CEDITS^DGRPECE(DFN)
     24 I DGRPS=8 D ^DGRPEIS,Q Q  ; family demographic edit...not conventional!!  :)
     25 I DGRPS=9 D EDIT9^DGRPEIS2,Q Q  ; income screening data ($$$)
     26 I DGRPS=5,DGDR["501," D
     27 .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q
     28 .D REG^IBCNBME(DFN)
     29 .Q
     30 N QUIT S QUIT=0
     31 I DGRPS=6,$S(DGDR["602,"!(DGDR["603,"):1,1:0) D  I QUIT D Q Q  ;Screen 6 subscreens
     32 . I DGDR["601," D  Q:QUIT
     33 .. D SETDR("601,",.DR)
     34 .. S (DA,Y)=DFN,DIE="^DPT("
     35 .. D ^DIE I $D(Y) S QUIT=1
     36 .. S DGDR=$P(DGDR,"601,",1)_$P(DGDR,"601,",2,999)
     37 . I DGDR["602," D EN^DGRP6CL(DFN,.QUIT)  Q:QUIT  ; Conflicts
     38 . I DGDR["603," D EN^DGRP6EF(DFN,.QUIT)  Q:QUIT  ; Exposures
     39 ;-- Tricare screen #15
     40 I DGRPS=15 D EDIT^DGRP15,Q Q
     41 ;
     42 N DGPH,DGPHFLG
     43 K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0
     44 G ^DGRPE1:DGRPS>6
     45 I DGRPS=4 D ^DGRPE4
     46 D SETDR(DGDR,.DR)
     47 S (DA,Y)=DFN,DIE="^DPT("
     48 D ^DIE
     49 ;check for Combat Vet status
     50 I $G(DGCVFLG)=1,($P($$CVEDT^DGCV(DFN),U,2)']"") D
     51 . W !!,"**NOTE-Change(s) made in this session deleted the veteran's Combat Vet status!"
     52 . S DIR(0)="EA" D ^DIR K DIR
     53 I $G(DGPHFLG)>0 D EDITPH1^DGRPLE()
     54Q K DA,DIE,DR,DGCT,DGCVFLG,DGDR,DGDRD,DGDRS,DGRPADI,I,J,J1,DGCOMLOC,DIPA
     55 Q
     56 ;
     57SETDR(DGDR,DR) ; Set up DR string(s) for edit groups selected
     58 N DGCT,DGDRS,J1,J2
     59 K DR S DR="",DGDRS="DR",DGCT=0
     60 F I=1:1 S J=$P(DGDR,",",I) Q:J=""  S J1=J D:$T(@J1)
     61 . S DGDRD=$P($T(@J1),";;",2) D S
     62 . N J2
     63 . F J2=0:1 S J1=J*1000+J2 Q:'$T(@J1)  S DGDRD=$P($T(@J1),";;",2) D S
     64 Q
     65 ;
     66S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q
     67 S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q
     68 Q
     69 ;
     70 ; VOE changes at lines 201, 202, 304 & after 305002
     71 ;
     72SETFLDS(DGDR) ; Set up fields to edit
     73 Q
     74 ;
     75101 ;;
     76102 ;;1;
     77103 ;;.091;
     78104 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);
     79105 ;;.12105//NO;S:X="N" Y="@15" S:X="Y" DIE("NO^")="";.1217;I X']"" W !?4,$C(7),"But I need a Start Date for this Temporary Address." S Y=.12105;.1218;.1211;I X']"" W !?4,$C(7),"But I need at least one line of a Temporary address." S Y=.12105;
     80105000 ;;.1212;S:X']"" Y=.1214;.1213:.1215;.12112;Q;.12111;.1219;@15;K DIE("NO^");
     81109 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);.02;D DR109^DGRPE;6;2;K DR(2,2.02),DR(2,2.06);.05;.08;K DIE("NO^");
     82111 ;;.14105//NO;S:X="N" Y="@111" S:X="Y" DIE("NO^")="";.1417;I X']"" W !?4,$C(7),"But I need a Start Date." S Y=.14105;.1418;D DR111^DGRPE;.141;I '$P($$CAACT^DGRPCADD(DFN),U,2) W !?4,"But I need at least one active category." S Y=.14105;
     83111000 ;;K DR(2,2.141);.1411;I X']"" W !?4,$C(7),"I need at least one line of Address." S Y=.14105;.1412;S:X']"" Y=.1414;.1413;.1414;.1415;.1416;Q;.14111;@111;K DIE("NO^");
     84112 ;;.134;.135;.133
     85201 ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE;;S:$G(DUZ("AG"))'="E" Y="@21";19902;19906;@21
     86202 ;;S:"IE"[$G(DUZ("AG")) Y="@22";1010.15//NO;S:X'="Y" Y="@22";S DIE("NO^")="";1010.152;I X']"" W !?4,*7,"But I need to know where you were treated most recently." S Y=1010.15;1010.151;1010.154;S:X']"" Y="@22";1010.153;@22;K DIE("NO^");
     87203 ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06);
     88205 ;;.181;
     89301 ;;.211;S:X']"" Y="@31";.212;.2125//NO;I X="Y" S DGADD=".21" D AD^DGRPE S Y=.21011;.213;S:X']"" Y=.216;.214;S:X']"" Y=.216;.215:.217;.2207;.219;.21011;@31;
     90302 ;;.2191;S:X']"" Y="@32";.2192;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y=.211011;
     91302000 ;;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195:.2197;.2203;.2199;.211011;@32;
     92303 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@33";.3305//NO;I X="Y" S Y="@34",DGX1=1 S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7);@33;.331;S:X']"" DGX1=2,Y="@34";.332;@34;
     93303000 ;;S:$G(DGX1) Y="@341";.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335:.337;.2201;.339;.33011;S DGX1=2;@341;
     94303001 ;;S:$G(DGX1)=2 Y="@35";S DGX2=$G(^DPT(DA,.21));.331///^S X=$P(DGX2,U);.332///^S X=$P(DGX2,U,2);.333////^S X=$P(DGX2,U,3);.334///^S X=$P(DGX2,U,4);@35;
     95303002 ;;S:$G(DGX1)=2 Y="@351";.335///^S X=$P(DGX2,U,5);.336///^S X=$P(DGX2,U,6);.337///^S X=$P(DGX2,U,7);.338///^S X=$P(DGX2,U,8);.339///^S X=$P(DGX2,U,9);.33011///^S X=$P(DGX2,U,11);@351;K DGX1,DGX2;
     96304 ;;.3311;S:X']"" Y="@36";.3312;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315:.3317;.2204;.3319;.331011;@36;       
     97305 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@37";.3405//NO;I X="Y" S DGX1=1,Y="@371" S:$D(^DPT(DFN,.22)) $P(^(.22),U,2)=$P(^(.22),U,7);@37;.341;S:X']"" DGX1=2,Y="@371";.342;@371;
     98305000 ;;S:$G(DGX1) Y="@38";.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345:.347;.2202;.349;.34011;S DGX1=2;@38;
     99305001 ;;S:$G(DGX1)=2 Y="@381";S DGX2=$G(^DPT(DA,.21));.341///^S X=$P(DGX2,U);.342///^S X=$P(DGX2,U,2);.343///^S X=$P(DGX2,U,3);.344///^S X=$P(DGX2,U,4);@381
     100305002 ;;S:$G(DGX1)=2 Y="@39";.345///^S X=$P(DGX2,U,5);.346///^S X=$P(DGX2,U,6);.347///^S X=$P(DGX2,U,7);.348///^S X=$P(DGX2,U,8);.349///^S X=$P(DGX2,U,9);.34011///^S X=$P(DGX2,U,11);@39;K DGX1,DGX2;
     101 ;;S:$G(DUZ("AG"))'="E" Y="@36";19903;19904;19905;@36401 ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;
     102401 ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;
     103402 ;;.2514;.2515;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@42" S:(X'=5) Y=.251;.2516;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42;
     104501 ;;
     105502 ;;.381;.382///NOW;
     106503 ;;.383;
     107601 ;;@60101;D SET32^DGRPE(DA,.DIPA,1);.325;S DIPA("X1")=X S:X="" Y="@60199" I X'="" S:$$FV^DGRPMS(X)'=1 Y="@60111";.3214;I X="" D PRF^DGRPE S Y="@60101";S Y="@6011";
     108601000 ;;@60111;D:DIPA("X1")'="" WARN32^DGRPE(DIPA("X1"),.DIPA,1,.Y);.32911;@6011;.328;.326;.327;.324;.3285//NO;S:X'="Y" Y="@60199";
     109601001 ;;@60102;D SET32^DGRPE(DA,.DIPA,2);.3291;S DIPA("X2")=X S:X="" Y="@60199" I X'="" S:$$FV^DGRPMS(X)'=1 Y="@60112";.3214;I X="" D PRF^DGRPE S Y="@60102";S Y="@6012";
     110601002 ;;@60112;D:DIPA("X2")'="" WARN32^DGRPE(DIPA("X2"),.DIPA,2,.Y);.32912;@6012;.3294;.3292;.3293;.329;.32945//NO;S:X'="Y" Y="@60199";
     111601003 ;;@60103;D SET32^DGRPE(DA,.DIPA,3);.3296;S DIPA("X3")=X S:X="" Y="@60199" I X'="" S:$$FV^DGRPMS(X)'=1 Y="@60113";.3214;I X="" D PRF^DGRPE S Y="@60103";S Y="@6013";
     112601004 ;;@60113;D:DIPA("X3")'="" WARN32^DGRPE(DIPA("X3"),.DIPA,3,.Y);.32913;@6013;.3299;.3297;.3298;.3295;@60199;
     113602 ;;Q;
     114603 ;;Q;
     115604 ;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62;
     116605 ;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63;
     117606 ;;I $P($G(^DPT(DFN,.361)),U,3)="H" S Y="@6131";.3602//NO;.3603//NO;S Y="@6132";@6131;.3602;.3603;@6132;
     118607 ;;.368//NO;.369//NO;I $S('$D(^DPT(DA,.36)):1,$P(^(.36),U,8)="Y"!($P(^(.36),U,9)="Y"):0,1:1) S Y="@614";.37;@614;
     119608 ;;S DGPHFLG=0;.531;S:X'="Y" DGX=X,Y="@616";.532///^S X="PENDING";S Y="@6161";@616;S:DGX'="N" Y="@6162";.533///^S X="VAMC";@6161;S DGPHFLG=1;.535///^S X=$$DIV^DGRPLE();@6162;
     120AD N DGZ4,DGPC
     121 S X=$S($D(^DPT(DA,.11)):^(.11),1:""),DGZ4=$P(X,U,12),DGPHONE=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(DGADD)):^(DGADD),1:""),^(DGADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_DGPHONE_U_$P(Y,U,10)
     122 I DGZ4 S DGPC=$S((DGADD=.33):1,(DGADD=.34):2,(DGADD=.211):3,(DGADD=.331):4,(DGADD=.311):5,(DGADD=.25):6,(DGADD=.21):7,1:0) S:DGPC $P(^DPT(DFN,.22),U,DGPC)=DGZ4
     123 K DGADD,DGPHONE Q
     124DR109 ;Drop through (use same logic as DR203)
     125DR203 S DR(2,2.02)=".01RACE;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.02,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2031"";.02;@2031;"
     126 S DR(2,2.06)=".01ETHNICITY;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.06,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2032"";.02;@2032;"
     127 Q
     128DR111 ;Set DR string for Confidential Address categories
     129 S DR(2,2.141)=".01;1//YES;"
     130 Q
     131PRF ; Write Proof needed for FV
     132 W !?4,$C(7),"Proof is required for Filipino vet."
     133 Q
     134 ;
     135SET32(DA,DIPA,SEQ) ; Extract the .32 node from patient file and set DIPA
     136 ; array with the BOS and component data for the SEQ military service
     137 ; episode (1-3)
     138 N I,Q,Z
     139 K DIPA(32,SEQ)
     140 S Q=$G(^DPT(DA,.32)),Z=$G(^(.3291))
     141 S DIPA(32,SEQ)=$P(Q,U,SEQ*5)_U_$P(Z,U,SEQ),DIPA("X"_SEQ)=$P(DIPA(32,SEQ),U)
     142 Q
     143 ;
     144WARN32(X,DIPA,SEQ,Y) ; Warn if the BOS is changed, then the component will
     145 ; be deleted
     146 ; Returns Y to skip component if the component should not be asked
     147 ;   for this branch of service
     148 N Z
     149 I '$$CMP(X) S Y="@601"_SEQ
     150 S Z=$G(DIPA(32,SEQ))
     151 Q:$S($P(Z,U,2)=""!($P(Z,U)=""):1,1:$P(Z,U)=X)
     152 ;
     153 I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",!
     154 Q
     155 ;
     156CMP(X) ; Function to determine if service component is valid for
     157 ; branch of service ien in X   0 = invalid  1 = valid 
     158 ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS
     159 Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0)
     160 ;
Note: See TracChangeset for help on using the changeset viewer.