AGFACE4.m

AGFACE4 ; IHS/ASDS/EFG - FACE SHEET (3RD PARTY (MEDICARE) ELIGIBILITY) ; 

 ;;7.1;PATIENT REGISTRATION;**2,4,13**;AUG 25, 2005;Build 1

 ;IHS/OIT/NKD AG*7.1*13 MBI IMPLEMENTATION

 ;MOVE LINES SO CAN READ THEM

 W !,$G(AG("-")),!?23,"*** THIRD PARTY ELIGIBILITY ***",!

 G END:'$D(^AUPNMCR(DFN,0))

 W "MEDICARE:",!,"TYPE",?20,"NUMBER",?46,"ELIG. DATE",?60,"ELIG. END DATE"

 ;F AG=1:1 S AG("DRENT")=AG,DIC=9000003.11,DA=DFN,DR=.02 D ^AGDICLK Q:$D(AG("LKERR"))  D L3A

 ;IM25256 OLD CODE ASSUMES CONTIGUOUS RECORDS EXIST

 N IENS,COVTYP

 S AG=0

 F  S AG=$O(^AUPNMCR(DFN,11,AG)) Q:'AG  D

 .S IENS=AG_","_DFN_","

 .S COVTYP=$$GET1^DIQ(9000003.11,IENS,.03,"I")

 .I COVTYP="D" W !,COVTYP,?20,$$GET1^DIQ(9000003.11,IENS,.06,"E")

 .;E  W !,COVTYP,?20,$$GET1^DIQ(9000003,DFN_",",.03,"E")

 .E  W !,COVTYP,?20,$$GETMCR^AGUTL(DFN)  ; IHS/OIT/NKD AG*7.1*13

 .;

 .;I COVTYP'="D" W $$GET1^DIQ(9000003,DFN_",",.04,"E")  ;SUFFIX

 .W ?46,$$GET1^DIQ(9000003.11,IENS,.01,"E")

 .W ?60,$$GET1^DIQ(9000003.11,IENS,.02,"E")

 ;END IM25256

 S DIC=9000003,DR=2101,DA=DFN D ^AGDICLK

 I $D(AG("LKPRINT")),AG("LKPRINT")]"" W !?3,"NAME: ",AG("LKPRINT")

 S DR=2102 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]""

 ;W !?3,"DATE OF BIRTH: ",AG("LKPRINT")

 W !?3,"DATE OF BIRTH: ",$G(AG("LKPRINT"))  ;AG*71.*2 IM21507

END Q

 ;CODE BELOW MADE OBSOLETE BY IM25256 FIX ABOVE - REMOVE AT NEXT VERSION

L3A S AG("DRENT")=AG,DR=.03 D ^AGDICLK Q:$D(AG("LKERR"))

 ;W !,AG("LKPRINT"),?20,$P(^AUPNMCR(DFN,0),U,3) ;AG*7.1*2 IM20222 IHS/SD/TPF 3/27/2006

 I $P($G(^AUPNMCR(DFN,11,AG,0)),U,3)="D" W !,AG("LKPRINT"),?20,$P($G(^AUPNMCR(DFN,11,AG,0)),U,6)

 E  W !,AG("LKPRINT"),?20,$P($G(^AUPNMCR(DFN,0)),U,3)

 ;END IM20222

 ;S DIC=9000003,DR=.04,DA=DFN D ^AGDICLK Q:$D(AG("LKERR"))  W AG("LKPRINT")

 I $P($G(^AUPNMCR(DFN,11,AG,0)),U,3)'="D" D

 .S DIC=9000003,DR=.04,DA=DFN D ^AGDICLK Q:$D(AG("LKERR"))  W AG("LKPRINT")  ;AG*7.1*2 IM23259

 S AG("DRENT")=AG,DR=.01,DIC=9000003.11 D ^AGDICLK I '$D(AG("LKERR")) W ?46,AG("LKPRINT")

 S AG("DRENT")=AG,DR=.02,DIC=9000003.11 D ^AGDICLK I '$D(AG("LKERR")) W ?60,AG("LKPRINT")

 Q

AGFACE4   ; IHS/ASDS/EFG - FACE SHEET (3RD PARTY (MEDICARE) ELIGIBILITY) ; 

 +1       ;;7.1;PATIENT REGISTRATION;**2,4,13**;AUG 25, 2005;Build 1

 +2       ;IHS/OIT/NKD AG*7.1*13 MBI IMPLEMENTATION

 +3       ;MOVE LINES SO CAN READ THEM

 +4        WRITE !,$GET(AG("-")),!?23,"*** THIRD PARTY ELIGIBILITY ***",!

 +5        IF '$DATA(^AUPNMCR(DFN,0))

               GOTO END

 +6        WRITE "MEDICARE:",!,"TYPE",?20,"NUMBER",?46,"ELIG. DATE",?60,"ELIG. END DATE"

 +7       ;F AG=1:1 S AG("DRENT")=AG,DIC=9000003.11,DA=DFN,DR=.02 D ^AGDICLK Q:$D(AG("LKERR"))  D L3A

 +8       ;IM25256 OLD CODE ASSUMES CONTIGUOUS RECORDS EXIST

 +9        NEW IENS,COVTYP

 +10       SET AG=0

 +11       FOR 

               SET AG=$ORDER(^AUPNMCR(DFN,11,AG))

               IF 'AG

                   QUIT 

               Begin DoDot:1

 +12               SET IENS=AG_","_DFN_","

 +13               SET COVTYP=$$GET1^DIQ(9000003.11,IENS,.03,"I")

 +14               IF COVTYP="D"

                       WRITE !,COVTYP,?20,$$GET1^DIQ(9000003.11,IENS,.06,"E")

 +15      ;E  W !,COVTYP,?20,$$GET1^DIQ(9000003,DFN_",",.03,"E")

 +16      ; IHS/OIT/NKD AG*7.1*13

                  IF '$TEST

                       WRITE !,COVTYP,?20,$$GETMCR^AGUTL(DFN)

 +17      ;

 +18      ;I COVTYP'="D" W $$GET1^DIQ(9000003,DFN_",",.04,"E")  ;SUFFIX

 +19               WRITE ?46,$$GET1^DIQ(9000003.11,IENS,.01,"E")

 +20               WRITE ?60,$$GET1^DIQ(9000003.11,IENS,.02,"E")

               End DoDot:1

 +21      ;END IM25256

 +22       SET DIC=9000003

           SET DR=2101

           SET DA=DFN

           DO ^AGDICLK

 +23       IF $DATA(AG("LKPRINT"))

               IF AG("LKPRINT")]""

                   WRITE !?3,"NAME: ",AG("LKPRINT")

 +24       SET DR=2102

           DO ^AGDICLK

           IF $DATA(AG("LKPRINT"))

               IF AG("LKPRINT")]""

 +25      ;W !?3,"DATE OF BIRTH: ",AG("LKPRINT")

 +26      ;AG*71.*2 IM21507

           WRITE !?3,"DATE OF BIRTH: ",$GET(AG("LKPRINT"))

END        QUIT 

 +1       ;CODE BELOW MADE OBSOLETE BY IM25256 FIX ABOVE - REMOVE AT NEXT VERSION

L3A        SET AG("DRENT")=AG

           SET DR=.03

           DO ^AGDICLK

           IF $DATA(AG("LKERR"))

               QUIT 

 +1       ;W !,AG("LKPRINT"),?20,$P(^AUPNMCR(DFN,0),U,3) ;AG*7.1*2 IM20222 IHS/SD/TPF 3/27/2006

 +2        IF $PIECE($GET(^AUPNMCR(DFN,11,AG,0)),U,3)="D"

               WRITE !,AG("LKPRINT"),?20,$PIECE($GET(^AUPNMCR(DFN,11,AG,0)),U,6)

 +3       IF '$TEST

               WRITE !,AG("LKPRINT"),?20,$PIECE($GET(^AUPNMCR(DFN,0)),U,3)

 +4       ;END IM20222

 +5       ;S DIC=9000003,DR=.04,DA=DFN D ^AGDICLK Q:$D(AG("LKERR"))  W AG("LKPRINT")

 +6        IF $PIECE($GET(^AUPNMCR(DFN,11,AG,0)),U,3)'="D"

               Begin DoDot:1

 +7       ;AG*7.1*2 IM23259

                   SET DIC=9000003

                   SET DR=.04

                   SET DA=DFN

                   DO ^AGDICLK

                   IF $DATA(AG("LKERR"))

                       QUIT 

                   WRITE AG("LKPRINT")

               End DoDot:1

 +8        SET AG("DRENT")=AG

           SET DR=.01

           SET DIC=9000003.11

           DO ^AGDICLK

           IF '$DATA(AG("LKERR"))

               WRITE ?46,AG("LKPRINT")

 +9        SET AG("DRENT")=AG

           SET DR=.02

           SET DIC=9000003.11

           DO ^AGDICLK

           IF '$DATA(AG("LKERR"))

               WRITE ?60,AG("LKPRINT")

 +10       QUIT