DGRPE1.m

DGRPE1 ;ALB/MRL,RTK,BRM,RGL,ERC,TDM - REGISTRATIONS EDITS (CONTINUED) ; 4/2/09 11:26am

 ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20

 ;

 ;***CONTAINS ISM SPECIFIC CODE TO AVOID STORE ERRORS WITH ELIG.***

 ;

 I DGRPS'=7 F I=1:1 S J=$P(DGDR,",",I) Q:J=""  F J1=J,J*1000 Q:'$T(@J1)  S DGDRD=$P($T(@J1),";;",2) D S

 I DGRPS=7 S DR="[DG LOAD EDIT SCREEN 7]"

 ;S DR(2,2.0361)=".01"

 D ^DIE K DIE,DR,DGCT,DGDR,DGDRD,DGDRS,I,J,J1

 ;update/set ELIGIBILITY VERIF. SOURCE field (327/Ineligible Project)

 I $D(^DPT(DFN,.361)) S DGELG=^DPT(DFN,.361) D

 .N DGXEL

 .S DGXEL=$P(DGELG,U,5),DATA(.3613)="V"

 .I $S($G(DGXEL)["CEV":1,$G(DGXEL)["VBA":1,$G(DGXEL)["VIVA":1,1:0),$P(DGELG,U,6)=.5 S DATA(.3613)="H"

 .I '$$UPD^DGENDBS(2,DFN,.DATA)

 Q

S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q

 S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q

701 ;;391;D SC7^DGRPV;1901;.301;S:X'="Y" Y=.313;.302;.313;.312;

702 ;;.361;D AAC1^DGLOCK2 S:DGAAC(1)']"" Y=361;.309;361;.323;D ^DGYZODS;S:'DGODS Y=.36265;11500.02;11500.03;.36265;S:X='"Y" Y="@72";.3626;@72;

703 ;;.3731;

1001 ;;.152;S:X="" Y="@101";.1651;.1653;.1654;.307;.1656;@101;

1002 ;;.153;S:X="" Y="@102";.1657:.1659;.16;@102;

1101 ;;.3611;.3612;.3614;.3615;

1102 ;;.306;

1103 ;;.322;

1104 ;;D VETTYPE^DGRPE1;D MSG^DGRPE1 S Y=0;@114;K DGRDCHG;D DR^DGRPE1;.302;.3721;D EFF^DGRPE1;D:$G(DGRDCHG) BULL^DGRPE1;K DGRDCHG;

MSG W !,"Patient is not a veteran.  Can't enter rated disabilities",! Q

 ;

BULL ; Rated Disabilities update bulletin

 ;

 Q        ; This bulletin has been disabled.  DG*5.3*808

 ;

 N DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT,XMSUB,XMDUZ

 S DGMGRP=$O(^XMB(3.8,"B","DGEN ELIGIBILITY ALERT",""))

 Q:'DGMGRP

 D XMY^DGMTUTL(DGMGRP,0,1)

 S DGNAME=$P($G(^DPT(DFN,0)),"^"),DGSSN=$P($G(^DPT(DFN,0)),"^",9)

 S XMTEXT="DGBULL("

 S XMSUB="RATED DISABILITY UPDATED"

 S DGLINE=0

 D LINE^DGEN("Patient: "_DGNAME,.DGLINE)

 D LINE^DGEN("SSN: "_DGSSN,.DGLINE)

 D LINE^DGEN("",.DGLINE)

 D LINE^DGEN("Send updates to SC Disabilities to HEC via fax or HECAlert",.DGLINE)

 D LINE^DGEN("Outlook mail group so that they can be entered into VHA's",.DGLINE)

 D LINE^DGEN("Authoritative Database.  SC Disability information entered directly",.DGLINE)

 D LINE^DGEN("into VistA may be overlaid.",.DGLINE)

 D ^XMD

 Q

DR ;

 K DGSCPC

 S DGSCPC=$P($G(^DPT(DFN,.3)),U,2)

 S DR(2,2.04)=".01;2;3"

 Q

EFF ;

 I $G(DGSCPC)=$P($G(^DPT(DFN,.3)),U,2) Q

 S DGFDA(2,DFN_",",.3014)="@"

 D FILE^DIE("","DGFDA","DGERR")

 K DGFDA,DGSCPC

 Q

VETTYPE ;

 S:$S('$D(^DPT(DFN,"VET")):0,^("VET")="Y":1,1:0) Y="@114" Q

 S:'$S('$D(^("TYPE")):1,'$D(^DG(391,+^("TYPE"),0)):1,$P(^(0),"^",2):0,1:1) Y="@114"

 Q

DGRPE1    ;ALB/MRL,RTK,BRM,RGL,ERC,TDM - REGISTRATIONS EDITS (CONTINUED) ; 4/2/09 11:26am

 +1       ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20

 +2       ;

 +3       ;***CONTAINS ISM SPECIFIC CODE TO AVOID STORE ERRORS WITH ELIG.***

 +4       ;

 +5        IF DGRPS'=7

               FOR I=1:1

                   SET J=$PIECE(DGDR,",",I)

                   IF J=""

                       QUIT 

                   FOR J1=J,J*1000

                       IF '$TEXT(@J1)

                           QUIT 

                       SET DGDRD=$PIECE($TEXT(@J1),";;",2)

                       DO S

 +6        IF DGRPS=7

               SET DR="[DG LOAD EDIT SCREEN 7]"

 +7       ;S DR(2,2.0361)=".01"

 +8        DO ^DIE

           KILL DIE,DR,DGCT,DGDR,DGDRD,DGDRS,I,J,J1

 +9       ;update/set ELIGIBILITY VERIF. SOURCE field (327/Ineligible Project)

 +10       IF $DATA(^DPT(DFN,.361))

               SET DGELG=^DPT(DFN,.361)

               Begin DoDot:1

 +11               NEW DGXEL

 +12               SET DGXEL=$PIECE(DGELG,U,5)

                   SET DATA(.3613)="V"

 +13               IF $SELECT($GET(DGXEL)["CEV":1,$GET(DGXEL)["VBA":1,$GET(DGXEL)["VIVA":1,1:0)

                       IF $PIECE(DGELG,U,6)=.5

                           SET DATA(.3613)="H"

 +14               IF '$$UPD^DGENDBS(2,DFN,.DATA)

               End DoDot:1

 +15       QUIT 

S          IF $LENGTH(@DGDRS)+$LENGTH(DGDRD)<241

               SET @DGDRS=@DGDRS_DGDRD

               QUIT 

 +1        SET DGCT=DGCT+1

           SET DGDRS="DR(1,2,"_DGCT_")"

           SET @DGDRS=DGDRD

           QUIT 

701       ;;391;D SC7^DGRPV;1901;.301;S:X'="Y" Y=.313;.302;.313;.312;

702       ;;.361;D AAC1^DGLOCK2 S:DGAAC(1)']"" Y=361;.309;361;.323;D ^DGYZODS;S:'DGODS Y=.36265;11500.02;11500.03;.36265;S:X='"Y" Y="@72";.3626;@72;

703       ;;.3731;

1001      ;;.152;S:X="" Y="@101";.1651;.1653;.1654;.307;.1656;@101;

1002      ;;.153;S:X="" Y="@102";.1657:.1659;.16;@102;

1101      ;;.3611;.3612;.3614;.3615;

1102      ;;.306;

1103      ;;.322;

1104      ;;D VETTYPE^DGRPE1;D MSG^DGRPE1 S Y=0;@114;K DGRDCHG;D DR^DGRPE1;.302;.3721;D EFF^DGRPE1;D:$G(DGRDCHG) BULL^DGRPE1;K DGRDCHG;

MSG        WRITE !,"Patient is not a veteran.  Can't enter rated disabilities",!

           QUIT 

 +1       ;

BULL      ; Rated Disabilities update bulletin

 +1       ;

 +2       ; This bulletin has been disabled.  DG*5.3*808

           QUIT 

 +3       ;

 +4        NEW DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT,XMSUB,XMDUZ

 +5        SET DGMGRP=$ORDER(^XMB(3.8,"B","DGEN ELIGIBILITY ALERT",""))

 +6        IF 'DGMGRP

               QUIT 

 +7        DO XMY^DGMTUTL(DGMGRP,0,1)

 +8        SET DGNAME=$PIECE($GET(^DPT(DFN,0)),"^")

           SET DGSSN=$PIECE($GET(^DPT(DFN,0)),"^",9)

 +9        SET XMTEXT="DGBULL("

 +10       SET XMSUB="RATED DISABILITY UPDATED"

 +11       SET DGLINE=0

 +12       DO LINE^DGEN("Patient: "_DGNAME,.DGLINE)

 +13       DO LINE^DGEN("SSN: "_DGSSN,.DGLINE)

 +14       DO LINE^DGEN("",.DGLINE)

 +15       DO LINE^DGEN("Send updates to SC Disabilities to HEC via fax or HECAlert",.DGLINE)

 +16       DO LINE^DGEN("Outlook mail group so that they can be entered into VHA's",.DGLINE)

 +17       DO LINE^DGEN("Authoritative Database.  SC Disability information entered directly",.DGLINE)

 +18       DO LINE^DGEN("into VistA may be overlaid.",.DGLINE)

 +19       DO ^XMD

 +20       QUIT 

DR        ;

 +1        KILL DGSCPC

 +2        SET DGSCPC=$PIECE($GET(^DPT(DFN,.3)),U,2)

 +3        SET DR(2,2.04)=".01;2;3"

 +4        QUIT 

EFF       ;

 +1        IF $GET(DGSCPC)=$PIECE($GET(^DPT(DFN,.3)),U,2)

               QUIT 

 +2        SET DGFDA(2,DFN_",",.3014)="@"

 +3        DO FILE^DIE("","DGFDA","DGERR")

 +4        KILL DGFDA,DGSCPC

 +5        QUIT 

VETTYPE   ;

 +1        IF $SELECT('$DATA(^DPT(DFN,"VET"))

               SET Y="@114"

           QUIT 

 +2        IF '$SELECT('$DATA(^("TYPE"))

               SET Y="@114"

 +3        QUIT