Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AGFACE4

AGFACE4.m

Go to the documentation of this file.
  1. AGFACE4 ; IHS/ASDS/EFG - FACE SHEET (3RD PARTY (MEDICARE) ELIGIBILITY) ;
  1. ;;7.1;PATIENT REGISTRATION;**2,4,13**;AUG 25, 2005;Build 1
  1. ;IHS/OIT/NKD AG*7.1*13 MBI IMPLEMENTATION
  1. ;MOVE LINES SO CAN READ THEM
  1. W !,$G(AG("-")),!?23,"*** THIRD PARTY ELIGIBILITY ***",!
  1. G END:'$D(^AUPNMCR(DFN,0))
  1. W "MEDICARE:",!,"TYPE",?20,"NUMBER",?46,"ELIG. DATE",?60,"ELIG. END DATE"
  1. ;F AG=1:1 S AG("DRENT")=AG,DIC=9000003.11,DA=DFN,DR=.02 D ^AGDICLK Q:$D(AG("LKERR")) D L3A
  1. ;IM25256 OLD CODE ASSUMES CONTIGUOUS RECORDS EXIST
  1. N IENS,COVTYP
  1. S AG=0
  1. F S AG=$O(^AUPNMCR(DFN,11,AG)) Q:'AG D
  1. .S IENS=AG_","_DFN_","
  1. .S COVTYP=$$GET1^DIQ(9000003.11,IENS,.03,"I")
  1. .I COVTYP="D" W !,COVTYP,?20,$$GET1^DIQ(9000003.11,IENS,.06,"E")
  1. .;E W !,COVTYP,?20,$$GET1^DIQ(9000003,DFN_",",.03,"E")
  1. .E W !,COVTYP,?20,$$GETMCR^AGUTL(DFN) ; IHS/OIT/NKD AG*7.1*13
  1. .;
  1. .;I COVTYP'="D" W $$GET1^DIQ(9000003,DFN_",",.04,"E") ;SUFFIX
  1. .W ?46,$$GET1^DIQ(9000003.11,IENS,.01,"E")
  1. .W ?60,$$GET1^DIQ(9000003.11,IENS,.02,"E")
  1. ;END IM25256
  1. S DIC=9000003,DR=2101,DA=DFN D ^AGDICLK
  1. I $D(AG("LKPRINT")),AG("LKPRINT")]"" W !?3,"NAME: ",AG("LKPRINT")
  1. S DR=2102 D ^AGDICLK I $D(AG("LKPRINT")),AG("LKPRINT")]""
  1. ;W !?3,"DATE OF BIRTH: ",AG("LKPRINT")
  1. W !?3,"DATE OF BIRTH: ",$G(AG("LKPRINT")) ;AG*71.*2 IM21507
  1. END Q
  1. ;CODE BELOW MADE OBSOLETE BY IM25256 FIX ABOVE - REMOVE AT NEXT VERSION
  1. L3A S AG("DRENT")=AG,DR=.03 D ^AGDICLK Q:$D(AG("LKERR"))
  1. ;W !,AG("LKPRINT"),?20,$P(^AUPNMCR(DFN,0),U,3) ;AG*7.1*2 IM20222 IHS/SD/TPF 3/27/2006
  1. I $P($G(^AUPNMCR(DFN,11,AG,0)),U,3)="D" W !,AG("LKPRINT"),?20,$P($G(^AUPNMCR(DFN,11,AG,0)),U,6)
  1. E W !,AG("LKPRINT"),?20,$P($G(^AUPNMCR(DFN,0)),U,3)
  1. ;END IM20222
  1. ;S DIC=9000003,DR=.04,DA=DFN D ^AGDICLK Q:$D(AG("LKERR")) W AG("LKPRINT")
  1. I $P($G(^AUPNMCR(DFN,11,AG,0)),U,3)'="D" D
  1. .S DIC=9000003,DR=.04,DA=DFN D ^AGDICLK Q:$D(AG("LKERR")) W AG("LKPRINT") ;AG*7.1*2 IM23259
  1. S AG("DRENT")=AG,DR=.01,DIC=9000003.11 D ^AGDICLK I '$D(AG("LKERR")) W ?46,AG("LKPRINT")
  1. S AG("DRENT")=AG,DR=.02,DIC=9000003.11 D ^AGDICLK I '$D(AG("LKERR")) W ?60,AG("LKPRINT")
  1. Q