DGENELA2.m

DGENELA2 ;ALB/CJM,ERC - Patient Eligibility API ; 13 JUN 1997

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

 ;

DELELIG(DFN,DGELG) ;

 ;Description: Deletes eligibilities from the patient file Patient

 ;Eligibilities multiple that are not contained in DGELG() array.

 ;

 ;Input:

 ;  DFN - ien of Patient record

 ;  DGELG() - eligibility array (pass by reference)

 ;Output: none

 ;

 N DIK,DA,CODE

 S DA(1)=DFN

 S DIK="^DPT("_DFN_",""E"","

 S DA=0 F  S DA=$O(^DPT(DFN,"E",DA)) Q:'DA  D

 .S CODE=+$G(^DPT(DFN,"E",DA,0))

 .;

 .;don't delete if it belongs

 .Q:$D(DGELG("ELIG","CODE",CODE))

 .;

 .;don't delete if it's the primary eligibility code

 .Q:(CODE=DGELG("ELIG","CODE"))

 .D ^DIK

 Q

 ;

DELRDIS(DFN) ;

 ;Description: deletes Rated Disability multiple from the patient file

 ;

 ;Input:

 ;  DFN - ien of Patient record

 ;Output: none

 ;

 N DIK,DA

 S DA(1)=DFN

 S DIK="^DPT("_DFN_",.372,"

 S DA=0 F  S DA=$O(^DPT(DFN,.372,DA)) Q:'DA  D ^DIK

 Q

UPDZ11 ;update the VistA Patient file record with data

 ;from the incoming Z11

 ;

 ;call moved from STORE^DGENELA1

 I '$$UPD^DGENDBS(2,DFN,.DATA) S ERROR="FILEMAN FAILED TO UPDATE THE PATIENT RECORD" Q

 ;

 ;check P&T and P&T Effective Date - the date field has a 

 ;lower field number if gets updated first.  And if the P&T was 'N' or

 ;null and the date field is set, the date field will be deleted by 

 ;the trigger cross reference on P&T

 N DATA3013

 I $G(DATA(.304))="Y",($G(DATA(.3013))]""),($P($G(^DPT(DFN,.3)),U,13)'=DATA(.3013)) D

 . S DATA3013(.3013)=DATA(.3013)

 . I '$$UPD^DGENDBS(2,DFN,.DATA3013) S ERROR="FILEMAN FAILED TO UPDATE P&T EFFECTIVE DATE" Q

 Q

DGENELA2  ;ALB/CJM,ERC - Patient Eligibility API ; 13 JUN 1997

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

 +2       ;

DELELIG(DFN,DGELG) ;

 +1       ;Description: Deletes eligibilities from the patient file Patient

 +2       ;Eligibilities multiple that are not contained in DGELG() array.

 +3       ;

 +4       ;Input:

 +5       ;  DFN - ien of Patient record

 +6       ;  DGELG() - eligibility array (pass by reference)

 +7       ;Output: none

 +8       ;

 +9        NEW DIK,DA,CODE

 +10       SET DA(1)=DFN

 +11       SET DIK="^DPT("_DFN_",""E"","

 +12       SET DA=0

           FOR 

               SET DA=$ORDER(^DPT(DFN,"E",DA))

               IF 'DA

                   QUIT 

               Begin DoDot:1

 +13               SET CODE=+$GET(^DPT(DFN,"E",DA,0))

 +14      ;

 +15      ;don't delete if it belongs

 +16               IF $DATA(DGELG("ELIG","CODE",CODE))

                       QUIT 

 +17      ;

 +18      ;don't delete if it's the primary eligibility code

 +19               IF (CODE=DGELG("ELIG","CODE"))

                       QUIT 

 +20               DO ^DIK

               End DoDot:1

 +21       QUIT 

 +22      ;

DELRDIS(DFN) ;

 +1       ;Description: deletes Rated Disability multiple from the patient file

 +2       ;

 +3       ;Input:

 +4       ;  DFN - ien of Patient record

 +5       ;Output: none

 +6       ;

 +7        NEW DIK,DA

 +8        SET DA(1)=DFN

 +9        SET DIK="^DPT("_DFN_",.372,"

 +10       SET DA=0

           FOR 

               SET DA=$ORDER(^DPT(DFN,.372,DA))

               IF 'DA

                   QUIT 

               DO ^DIK

 +11       QUIT 

UPDZ11    ;update the VistA Patient file record with data

 +1       ;from the incoming Z11

 +2       ;

 +3       ;call moved from STORE^DGENELA1

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

               SET ERROR="FILEMAN FAILED TO UPDATE THE PATIENT RECORD"

               QUIT 

 +5       ;

 +6       ;check P&T and P&T Effective Date - the date field has a 

 +7       ;lower field number if gets updated first.  And if the P&T was 'N' or

 +8       ;null and the date field is set, the date field will be deleted by 

 +9       ;the trigger cross reference on P&T

 +10       NEW DATA3013

 +11       IF $GET(DATA(.304))="Y"

               IF ($GET(DATA(.3013))]"")

                   IF ($PIECE($GET(^DPT(DFN,.3)),U,13)'=DATA(.3013))

                       Begin DoDot:1

 +12                       SET DATA3013(.3013)=DATA(.3013)

 +13                       IF '$$UPD^DGENDBS(2,DFN,.DATA3013)

                               SET ERROR="FILEMAN FAILED TO UPDATE P&T EFFECTIVE DATE"

                               QUIT 

                       End DoDot:1

 +14       QUIT