- 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
