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