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
