- 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