AG2 ; IHS/ASDS/EFG - ELIGIBILITY AND TRIBAL DATA ;
;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
L1 D S1,^AG1 G K^AG0:$D(DFOUT)!$D(DTOUT),UP:$D(DUOUT)
I $D(AGDOG) G:'$D(AG("TEMP CHART")) K^AG0
I $D(AG("TEMP CHART")) D S1,DOB^AG2A,S1,SEX^AG2A Q
L5 D S1,BEN^AG2A
;AFTER RETURNING FROM BEN^AG2A IF THE BENEFICIARY NAME CONTAINED
;"NON-INDIAN" THEN THE GUARANTOR PAGE MUST BE FILLED OUT. CERTAIN
;FIELDS ARE REQUIRED PER SPECS. ON RETURN HERE THE VARIABLE ALLFLDRQ
;WILL BE TRUE
G L1:$D(DUOUT),K^AG0:$D(DFOUT)!$D(DTOUT)
I $D(X),X]"",$D(^AUTTBEN(X,0)) S X=$P(^(0),U,2)
W !!!
G L5:X=""&('$G(ALLFLDRQ)) ;ALLFLDRQ=1 SIGNIFIES NON-INDIAN
S DIE="^AUPNPAT(",DA=DFN
TRIB D S1,TRIBE^AG2A G L5:$D(DUOUT),K^AG0:$D(DFOUT)!$D(DTOUT),IQTM:'$D(^AUPNPAT(DFN,11)),IQTM:$P(^(11),U,8)="" ;-----
I $D(^AUPNPAT(DFN,11)),$P(^(11),U,8)'["" W *7,!,"<Tribe Required>" G TRIB ;-----
I $D(^AUPNPAT(DFN,11)),$P(^(11),U,8)]"",($P(^AUTTTRI($P(^AUPNPAT(DFN,11),U,8),0),U,4)="Y") W !,"That TRIBE not acceptable." G L5
S AG("TRINUM")=+$P(^AUTTTRI($P(^AUPNPAT(DFN,11),U,8),0),U,2) F AGXXX=0,999,970 I AG("TRINUM")=AGXXX K AGXXX,AG("TRINUM") S DR="1109////NONE;1110////NONE",DA=DFN D ^DIE G COM ;-----
K AGXXX,AG("TRINUM")
TRINUM I AGOPT(2)="Y" D S1,TRINUM^AGOPT2 G TRIB:$D(DUOUT) I 1
E G TRIB:$D(DUOUT)
IQTM D S1,IQTM^AG2A
G TRIB:$D(DUOUT)&($P(^AUPNPAT(DFN,11),U,8)=""),TRINUM:$D(DUOUT),K^AG0:$D(DFOUT)!$D(DTOUT)
I X="NONE"&('$G(ALLFLDRQ)) W *7,!!?5,"ERROR: Inconsistancy, Native American with Blood Quantity of NONE?" G L5
TQTM I AGOPT(1)="Y" D S1,TQTM^AGOPT2 G IQTM:$D(DUOUT)
G:$D(DUOUT) IQTM
I X="NONE"&('$G(ALLFLDRQ)) W *7,!!?5,"ERROR: Inconsistancy, Tribal Member with Blood Quantity of NONE?" G TRIB
OTHRTR I AGOPT(8)="Y" D S1,OTHRTR^AGOPT2 G TQTM:$D(DUOUT) I 1
E G TQTM:$D(DUOUT)
COM D S1,^AG2B I $D(DUOUT),$D(^AUPNPAT(DFN,11)),$P(^(11),U,11)]"",$P(^AUTTBEN($P(^(11),U,11),0),U,2)'="01" G L5
G OTHRTR:$D(DUOUT)!$D(DTOUT),K^AG0:$D(DFOUT)
ELIG D S1,ELIG^AG2A
G COM:$D(DUOUT),K^AG0:$D(DFOUT)!$D(DTOUT)
I X="I",$D(^AUPNPAT(DFN,11)),$P(^(11),U,11)]"",$P(^AUTTBEN($P(^(11),U,11),0),U,2)="01" W *7,!!?5,"ERROR: Inconsistancy, Native American with Status of INELIGIBLE?" G L5
;S AGWM=1 D ^AGELCHK I $D(AG("ER",9)) K AG("ER"),AGWM G L5
;IF NOT A NON BEN THEN DO THE QUANTUM CHECKS. SEE E-MAIL 6/5/2006 SUBJECT BUG WHEN ENTERING NON-BEN
I '$G(ALLFLDRQ) S AGWM=1 D ^AGELCHK I $D(AG("ER",9)) K AG("ER"),AGWM G L5
K AG("ER"),AGWM
END K AG
G ^AG3
S1 K DFOUT,DTOUT,DUOUT,DLOUT,DQOUT Q
UP S AG("EDIT")="",AG("NAME")=$P(^DPT(DFN,0),U) W !!,*7,*7,"Deleting Patient ",AG("NAME")," ...." D Z1^AGKPAT,DFN^AGKPAT G L1^AG0
AG2 ; IHS/ASDS/EFG - ELIGIBILITY AND TRIBAL DATA ;
+1 ;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007
L1 DO S1
DO ^AG1
IF $DATA(DFOUT)!$DATA(DTOUT)
GOTO K^AG0
IF $DATA(DUOUT)
GOTO UP
+1 IF $DATA(AGDOG)
IF '$DATA(AG("TEMP CHART"))
GOTO K^AG0
+2 IF $DATA(AG("TEMP CHART"))
DO S1
DO DOB^AG2A
DO S1
DO SEX^AG2A
QUIT
L5 DO S1
DO BEN^AG2A
+1 ;AFTER RETURNING FROM BEN^AG2A IF THE BENEFICIARY NAME CONTAINED
+2 ;"NON-INDIAN" THEN THE GUARANTOR PAGE MUST BE FILLED OUT. CERTAIN
+3 ;FIELDS ARE REQUIRED PER SPECS. ON RETURN HERE THE VARIABLE ALLFLDRQ
+4 ;WILL BE TRUE
+5 IF $DATA(DUOUT)
GOTO L1
IF $DATA(DFOUT)!$DATA(DTOUT)
GOTO K^AG0
+6 IF $DATA(X)
IF X]""
IF $DATA(^AUTTBEN(X,0))
SET X=$PIECE(^(0),U,2)
+7 WRITE !!!
+8 ;ALLFLDRQ=1 SIGNIFIES NON-INDIAN
IF X=""&('$GET(ALLFLDRQ))
GOTO L5
+9 SET DIE="^AUPNPAT("
SET DA=DFN
TRIB ;-----
DO S1
DO TRIBE^AG2A
IF $DATA(DUOUT)
GOTO L5
IF $DATA(DFOUT)!$DATA(DTOUT)
GOTO K^AG0
IF '$DATA(^AUPNPAT(DFN,11))
GOTO IQTM
IF $PIECE(^(11),U,8)=""
GOTO IQTM
+1 ;-----
IF $DATA(^AUPNPAT(DFN,11))
IF $PIECE(^(11),U,8)'[""
WRITE *7,!,"<Tribe Required>"
GOTO TRIB
+2 IF $DATA(^AUPNPAT(DFN,11))
IF $PIECE(^(11),U,8)]""
IF ($PIECE(^AUTTTRI($PIECE(^AUPNPAT(DFN,11),U,8),0),U,4)="Y")
WRITE !,"That TRIBE not acceptable."
GOTO L5
+3 ;-----
SET AG("TRINUM")=+$PIECE(^AUTTTRI($PIECE(^AUPNPAT(DFN,11),U,8),0),U,2)
FOR AGXXX=0,999,970
IF AG("TRINUM")=AGXXX
KILL AGXXX,AG("TRINUM")
SET DR="1109////NONE;1110////NONE"
SET DA=DFN
DO ^DIE
GOTO COM
+4 KILL AGXXX,AG("TRINUM")
TRINUM IF AGOPT(2)="Y"
DO S1
DO TRINUM^AGOPT2
IF $DATA(DUOUT)
GOTO TRIB
IF 1
+1 IF '$TEST
IF $DATA(DUOUT)
GOTO TRIB
IQTM DO S1
DO IQTM^AG2A
+1 IF $DATA(DUOUT)&($PIECE(^AUPNPAT(DFN,11),U,8)="")
GOTO TRIB
IF $DATA(DUOUT)
GOTO TRINUM
IF $DATA(DFOUT)!$DATA(DTOUT)
GOTO K^AG0
+2 IF X="NONE"&('$GET(ALLFLDRQ))
WRITE *7,!!?5,"ERROR: Inconsistancy, Native American with Blood Quantity of NONE?"
GOTO L5
TQTM IF AGOPT(1)="Y"
DO S1
DO TQTM^AGOPT2
IF $DATA(DUOUT)
GOTO IQTM
+1 IF $DATA(DUOUT)
GOTO IQTM
+2 IF X="NONE"&('$GET(ALLFLDRQ))
WRITE *7,!!?5,"ERROR: Inconsistancy, Tribal Member with Blood Quantity of NONE?"
GOTO TRIB
OTHRTR IF AGOPT(8)="Y"
DO S1
DO OTHRTR^AGOPT2
IF $DATA(DUOUT)
GOTO TQTM
IF 1
+1 IF '$TEST
IF $DATA(DUOUT)
GOTO TQTM
COM DO S1
DO ^AG2B
IF $DATA(DUOUT)
IF $DATA(^AUPNPAT(DFN,11))
IF $PIECE(^(11),U,11)]""
IF $PIECE(^AUTTBEN($PIECE(^(11),U,11),0),U,2)'="01"
GOTO L5
+1 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO OTHRTR
IF $DATA(DFOUT)
GOTO K^AG0
ELIG DO S1
DO ELIG^AG2A
+1 IF $DATA(DUOUT)
GOTO COM
IF $DATA(DFOUT)!$DATA(DTOUT)
GOTO K^AG0
+2 IF X="I"
IF $DATA(^AUPNPAT(DFN,11))
IF $PIECE(^(11),U,11)]""
IF $PIECE(^AUTTBEN($PIECE(^(11),U,11),0),U,2)="01"
WRITE *7,!!?5,"ERROR: Inconsistancy, Native American with Status of INELIGIBLE?"
GOTO L5
+3 ;S AGWM=1 D ^AGELCHK I $D(AG("ER",9)) K AG("ER"),AGWM G L5
+4 ;IF NOT A NON BEN THEN DO THE QUANTUM CHECKS. SEE E-MAIL 6/5/2006 SUBJECT BUG WHEN ENTERING NON-BEN
+5 IF '$GET(ALLFLDRQ)
SET AGWM=1
DO ^AGELCHK
IF $DATA(AG("ER",9))
KILL AG("ER"),AGWM
GOTO L5
+6 KILL AG("ER"),AGWM
END KILL AG
+1 GOTO ^AG3
S1 KILL DFOUT,DTOUT,DUOUT,DLOUT,DQOUT
QUIT
UP SET AG("EDIT")=""
SET AG("NAME")=$PIECE(^DPT(DFN,0),U)
WRITE !!,*7,*7,"Deleting Patient ",AG("NAME")," ...."
DO Z1^AGKPAT
DO DFN^AGKPAT
GOTO L1^AG0
