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

AG2A.m

Go to the documentation of this file.
  1. AG2A ; IHS/ASDS/EFG - ENTER & EDIT MANDATORY DATA ;
  1. ;;7.1;PATIENT REGISTRATION;**2,8,11**;AUG 25, 2005;Build 1
  1. ;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
  1. ;
  1. ;IF BENEFICIARY CONTAINS NON-INDIAN THEN
  1. ;GUARANTOR INFORMATION MUST BE ENTERED
  1. ;
  1. DOB ;EP - Date of Birth.
  1. S AGOLD("DOB")=$P(^DPT(DFN,0),U,3)
  1. I $P(^AUPNPAT(DFN,0),U,23)]"" D
  1. . I $D(^AUTTSSN($P(^AUPNPAT(DFN,0),U,23),0)) D
  1. .. I "XV"[$P(^AUTTSSN($P(^AUPNPAT(DFN,0),U,23),0),U) D
  1. ... W !!,*7,"The NAME/SSN/DOB have been Verfied by the SSA do not change the DOB unless you are"
  1. ... W !,"certain that it is incorrect!"
  1. I $D(AG("PG")),AGOPT(12)="Y",'$D(^XUSEC("AGZMGR",DUZ)) D Q
  1. . W !!,*7,"DOB must be edited by a supervisor."
  1. . H 3
  1. D S2
  1. S DR=.03
  1. D END
  1. I $P(^DPT(DFN,0),U,3)'=AGOLD("DOB") D
  1. . S DIE="^AUPNPAT("
  1. . S DA=DFN
  1. . S DR=".23///@"
  1. . D ^DIE
  1. K AGOLD("DOB")
  1. Q
  1. SEX ;EP - Sex.
  1. S AGOLD("SEX")=$P(^DPT(DFN,0),U,2)
  1. I $P(^AUPNPAT(DFN,0),U,23)]"" D
  1. . I $D(^AUTTSSN($P(^AUPNPAT(DFN,0),U,23),0)) D
  1. .. I "XV"[$P(^AUTTSSN($P(^AUPNPAT(DFN,0),U,23),0),U) D
  1. ... W !!,*7,"The NAME/SSN/SEX have been Verfied by the SSA do not change the SEX unless you're"
  1. ... W !,"certain that it is incorrect!"
  1. D S2
  1. S DR=.02
  1. D END
  1. ;IHS/OIT/NKD AG*7.1*11 MU2 - CONFIRM CHANGE OF SEX TO UNKNOWN - START NEW CODE
  1. I AGOLD("SEX")'="U",$P(^DPT(DFN,0),U,2)="U" D
  1. . K DIR S DIR(0)="Y",DIR("B")="N"
  1. . S DIR("A",1)="You are attempting to change the Patient SEX to 'UNKNOWN'."
  1. . S DIR("A")="Please confirm this is correct (Y/N)"
  1. . D ^DIR K DIR
  1. . I Y=0 D
  1. . . W !,"Unconfirmed. Reverting Patient SEX to previous value."
  1. . . S DIE="^DPT("
  1. . . S DA=DFN
  1. . . S DR=".02////"_AGOLD("SEX")
  1. . . D ^DIE
  1. . . H 2
  1. ;IHS/OIT/NKD AG*7.1*11 END NEW CODE
  1. I $P(^DPT(DFN,0),U,2)'=AGOLD("SEX") D
  1. . S DIE="^AUPNPAT("
  1. . S DA=DFN
  1. . S DR=".23///@"
  1. . D ^DIE
  1. . ;IHS/OIT/NKD AG*7.1*11 MU2 - MODIFY ASSOCIATED ELIGIBLE SEX/GENDER FIELDS
  1. . D SEXELIG^AGUTL(DFN)
  1. K AGOLD("SEX")
  1. Q
  1. TRIBE ;EP - Tribe.
  1. S DIC="^AUPNPAT("
  1. S DR=1108
  1. S DA=DFN
  1. K ^UTILITY("DIQ1",$J)
  1. S DIC("B")=$$GET1^DIQ(9000001,DFN,DR)
  1. S DIC="^AUTTTRI("
  1. S DIC(0)="AEFMQZ"
  1. S DIC("A")=$P(^DD(9000001,1108,0),U)_" : ",DIC("S")="I $P(^(0),U,4)'=""Y"""
  1. D ^DIC
  1. K DIC
  1. Q:$D(DUOUT)!(+Y<1)
  1. S DIE="^AUPNPAT("
  1. S DA=DFN
  1. S DR="1108////"_+Y
  1. D ^DIE
  1. I AGOPT(14)'="N" D TRBFLG,TRBMNR^AGBIC2:'$D(DUOUT)
  1. Q
  1. TRBFLG ;EP - Enter Tribe Verified Flag.
  1. S DR=1119
  1. D S1,END
  1. Q
  1. TQTM ;Tribal Blood Quantum.
  1. D S1
  1. S DR=1109
  1. D END
  1. Q
  1. TRINUM ;Tribal Enrollment Number.
  1. D S1
  1. S DR=.07
  1. D END
  1. Q
  1. IQTM ;EP - Indian Blood Quantum.
  1. D S1
  1. S DR=1110
  1. D END
  1. Q
  1. BEN ;EP - Beneficiary Code.
  1. BEN1 ;
  1. N DRTEMP
  1. S ALLFLDRQ=0 ;ASSUME PATIENT IS NATIVE AMERICAN. USED AS FLAG IN AG2
  1. W !
  1. S DIC="^AUTTBEN("
  1. S DIC(0)="QAZEM"
  1. S DIC("A")="Select CLASSIFICATION/BENEFICIARY: " ;AG*7.1*8
  1. S DIC("B")=$S('$D(^AUPNPAT(DFN,11)):"",1:$P(^(11),U,11))
  1. S:DIC("B")="" DIC("B")="INDIAN/ALASKA NATIVE"
  1. S DIC("S")="I $P(^(0),U,3)'=""I"""
  1. D ^DIC
  1. S Y=+Y
  1. K DIC("S"),DIC("B")
  1. Q:Y<1
  1. D S1
  1. S DR="1111///"_$P(Y(0),U)
  1. S BENTEMP=$P(Y(0),U)
  1. D END
  1. ;IF BENEFICIARY CONTAINS NON-INDIAN THEN
  1. ;GUARANTOR INFORMATION MUST BE ENTERED
  1. GUARREQ ;
  1. Q:BENTEMP[("NON-INDIAN SPOUSE") ;IHS/SD/TPF 5/1/2006 AG*7.1*2 PAGE 11 ITEM 14
  1. ;ABOVE- DO NOT INCLUDE NON-INDIAN SPOUSE THEY ARE COVERED PER SANDRA
  1. I BENTEMP[("NON-INDIAN") D
  1. .S ALLFLDRQ=1 ;ALL FIELDS REQUIRED IN GUARANTOR PAGE FOR NON-INDIAN
  1. .Q:$D(^AUPNGUAR(DFN)) ;QUIT IF GUARANTOR INFO ALREADY ENTERED
  1. .S PARDFN=DFN
  1. .S PARDT=""
  1. .S PARFIL=""
  1. .S NEWENTRY=1
  1. .D EN^AGEDGUAR(PARDFN,PARFIL,PARDT,NEWENTRY,"",ALLFLDRQ)
  1. .K PARDFN,PARFIL,PARDT,NEWENTRY
  1. .I '$D(^AUPNGUAR(DFN)) W !,"GUARANTOR INFORMATION MANDATORY FOR NON-INDIAN!" H 2 G GUARREQ
  1. K BENTEMP
  1. Q
  1. BENED ;EP - Classification / Beneficiary (string in AGED2).
  1. D S1
  1. S DR=1111
  1. D END
  1. Q
  1. ELIG ;EP - Eligibility Status.
  1. D S1
  1. S DR=1112
  1. D END
  1. I $D(AG("SVELIG")) D
  1. . I $P($G(^AUPNPAT(DFN,11)),U,12)'=AG("SVELIG") D
  1. .. S MODREC=0
  1. .. F S MODREC=$O(^AUPNPAT(DFN,34,MODREC)) Q:'MODREC D
  1. ... S DA(1)=DFN
  1. ... S DIK="^AUPNPAT("_DA(1)_",34,"
  1. ... S DA=MODREC
  1. ... D ^DIK K DA,DA(1),DIK
  1. Q
  1. S1 ;
  1. K DUOUT
  1. S DIE="^AUPNPAT("
  1. S DA=DFN
  1. W !
  1. Q
  1. S2 ;
  1. K DUOUT
  1. S DIE="^DPT("
  1. S DA=DFN
  1. W !
  1. Q
  1. END ;
  1. D ^DIE
  1. S:$D(Y) DUOUT=""
  1. K DIC
  1. Q