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

AGELCHK.m

Go to the documentation of this file. 
  1. AGELCHK ; IHS/ASDS/EFG - TRIBE-QUANTUM-BEN CODE CONSISTENCY CHECKER ;  
  1.  ;;7.1;PATIENT REGISTRATION;**4,5**;AUG 25,2005
  1.  ;
  1.  ; ****************************************************************
  1.  ; This will return AG("ER",9)="" if the entry is inconsistant
  1.  ; If AGWM is set=1 then messages will be writen out
  1.  ; DFN is required
  1.  ; ****************************************************************
  1.  ;
  1. SET ;
  1.  S:'$D(AGWM) AGWM=0
  1.  ;AGWM is to be set prior if Writing Messages is desired
  1.  K AG("ER",9)
  1.  I $D(^AUPNPAT(DFN,11)) D
  1.  . S AG11=^AUPNPAT(DFN,11)
  1.  . S AGB=$P(AG11,U,11)          ;CLASS/BENEFICIARY
  1.  . S AGTP=$P(AG11,U,8)          ;TRIBE OF MEMBERSHIP
  1.  . S AGQT=$P(AG11,U,9)          ;TRIBE QUANTUM
  1.  . S AGQI=$P(AG11,U,10)         ;INDIAN BLOOD QUANTUM
  1.  . S AGEL=$P(AG11,U,12)         ;ELIGIBILITY STATUS
  1.  E  D  G EXIT
  1.  . S AG("ER",9)=""
  1.  . W:AGWM !,"< Missing Eligibility, Beneficiary, Tribal Information >"
  1. S ;
  1. TRIBE ;
  1.  ;I $L(AGTP),$D(^AUTTTRI(AGTP,0)),$P(^(0),U,4)="N" S AGT=$P(^AUTTTRI(AGTP,0),U,2)
  1.  I $L(AGTP),$D(^AUTTTRI(AGTP,0)),($P(^(0),U,4)="N"!($P(^(0),U,4)="")) S AGT=$P(^AUTTTRI(AGTP,0),U,2)  ;IHS/SD/TPF AG*7.1*4 IM23957
  1.  E  D  G ELIG
  1.  . S AG("ER",9)=""
  1.  . S AGT=0
  1.  . W:AGWM !,"<< INVALID old TRIBE >>"
  1.  S AGT=+AGT
  1.  S AGB=+AGB
  1.  G:+AGB=1 IND                        ;BEN = Indian
  1.  F I=6,18,32,33,8 I +AGB=I G NON
  1.  ;all other BEN and tribe combinations are acceptable
  1.  G ELIG
  1.  ;****************************************************************
  1. IND ;check BEN=1 TR'=000,970
  1.  I AGT>0,AGT'=970 G ELIG
  1.  E  D
  1.  . S AG("ER",9)=""
  1.  . W:AGWM !,"<< Native American requires Valid Indian Tribe >>"
  1.  G ELIG
  1.  ;****************************************************************
  1. NON ;BEN - NON INDIAN TR=000,970
  1.  I AGB=8,((AGT=0)!(AGT=999)!(AGT=970)) G ELIG
  1.  E  I AGB=8 D  G ELIG
  1.  . S AG("ER",9)=""
  1.  . W:AGWM !,"< 'OTHER' Ben/Class requires 'Non-Indian' or 'Unspecified' Tribe >"
  1.  I ((AGT=0)!(AGT=970)) G ELIG
  1.  E  D
  1.  . ;I AGT=990 Q  ;IHS/SD/TPF H5933
  1.  . S AG("ER",9)=""
  1.  . W:AGWM !,"< 'Non-Indian' Ben/Class requires 'Non-Indian' Tribe >"
  1.  G ELIG
  1.  ;****************************************************************
  1. ELIG ;Check Eligibility
  1.  I AGEL']"" D
  1.  . S AG("ER",9)=""
  1.  . W:AGWM !,"< Eligibility Missing >"
  1.  I ((AGB=1)!(AGB=3)!(AGB=4)),AGEL="I" D
  1.  . S AG("ER",9)=""
  1.  . W:AGWM !,"< Ben/Class selected should be Eligible for care >"
  1. TRBQT ;
  1.  ;Check Tribe and Indian Quantum consistency
  1.  ;I AGT=990,("NONE")[AGQI Q  ;IHS/SD/TPF H5933
  1.  S AGTF=1
  1.  I ((AGT=0)!(AGT=970)) S AGTF=0
  1.  I AGT=999 F AGZ=6,8,18,32,33 S:AGB=AGZ AGTF=0
  1.  I AGTF,AGEL="I" W:AGWM !,"< WARNING ... Valid Tribe should be Eligible for Care >",*7
  1.  S AGQF=0
  1.  I "UNKNOWN,NONE"'[AGQI S AGQF=1
  1.  I AGTF=AGQF
  1.  E  D
  1.  . S AG("ER",9)=""
  1.  . W:AGWM !,"< Tribe Selected and Indian Quantum are Inconsistent >"
  1. QTCHK ;
  1.  ;Check Quantums consistency
  1.  I '$G(AGSITE),'$D(^AGFAC(DUZ(2))) Q
  1.  I $G(AGSITE),'$D(^AGFAC(AGSITE)) Q
  1.  I $P(^AGFAC($S($D(AGSITE):AGSITE,1:DUZ(2)),0),"^",2)'="Y" G END
  1.  G:AGQT=AGQI END
  1.  I "UNKNOWN,NONE"'[AGQI,"UNKNOWN,NONE"'[AGQT
  1.  E  D
  1.  . S AG("ER",9)=""
  1.  . W:AGWM !,"< Quantums are Inconsistent >"
  1. END ;
  1. EXIT ;return to calling program
  1.  K AGT,AG11,AGB,AGEL,AGWM,AGTF,AGQF
  1.  Q