AGBICEDZ.m

AGBICEDZ ; IHS/ASDS/EFG - ;  

 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005

 D PTLK^AG

 Q:'$D(DFN)  D VIDEO^AG S AG("SVELIG")="" I $D(^AUPNPAT(DFN,11)) S AG("SVELIG")=$P(^(11),U,24)

 Q:'$D(^DPT(DFN,0))  S AG("PG")="BICFLDS",AGPAT=$P(^DPT(DFN,0),U),AGCHRT=$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2),AG("AUPN")="" S:$D(^AUPNPAT(DFN,0)) AG("AUPN")=^(0)

 S AGUPDT="" S Y=$P(AG("AUPN"),U,3) I Y]"" D DD^%DT S AGUPDT="(updated: "_Y_")"

 I AGUPDT="" S Y=$P(AG("AUPN"),U,2) I Y]"" D DD^%DT S AGUPDT="(file est: "_Y_")"

 S AGLINE("-")="W !,""------------------------------------------------------------------------------""",AGLINE("EQ")="W !,""=============================================================================="""

VAR D ^AGBIC2C,^AGED S DA=DFN,DR=1124,DIC=9000001 D ^AGDICLK W !!,"IHS ELIGIBILITY : ",AG("LKPRINT"),!!

 W !,"1.       COMMUNITY:" I $D(^AUPNPAT(DFN,11)) W ?22,$P(^(11),U,18) I $P(^(11),U,18)]"" W $S($P(^(11),U,21)="Y":" (VERIFIED)",$P(^(11),U,21)="N":" (UNVERIFIED)",1:" (UNVERIFIED)")

 W !,"2.           TRIBE:",?22 S AG("Y")=$P(^AUPNPAT(DFN,11),U,8)

 I AG("Y")]"",$D(^AUTTTRI(AG("Y"))) W $P(^AUTTTRI(AG("Y"),0),U) I $P(^(0),U,4)="Y" W ?$X+2,$$S^AGVDF("RVN"),"(OLD UNUSED TRIBE NAME)",$$S^AGVDF("RVF")

 I $D(^AUPNPAT(DFN,11)),$P(^(11),U,8)]"",$P(^(11),U,19)]"" W $S($P(^(11),U,19)="Y":" (VERIFIED)",$P(^(11),U,19)="U":" (UNABLE TO VERIFY (NO TRIBAL ROLE))",1:" (UNVERIFIED)")

 W !,"3.  INDIAN QUANTUM:",?22,$P(^AUPNPAT(DFN,11),U,10),! W !,AGLINE("EQ")

 W !!?23,"CHANGE which item? (1-3) NONE// " D READ^AGED1 Q:$D(DUOUT)!$D(DTOUT)!$D(DFOUT)  G END:$D(DLOUT)!(Y["N"),VAR:$D(AG("ERR")) I $D(DQOUT)!(+Y<1)!(+Y>3) D QUES^AGED1 G VAR

 S AG("SEL")=+Y

L7 D @($P("EDCOM^AG2B,TRIBE^AG2A,IQTM^AG2A",",",AG("SEL")))

 I AG("SEL")="1" G:'$D(AG("COMAGED1")) VAR S DIE="^AUPNPAT(",DA=DFN,DR="1121///"_AG("COMAGED1") D ^DIE,^AGBIC2C G ENDOPT

 I AG("SEL")=2&($P(^AUTTTRI($P(^AUPNPAT(DFN,11),U,8),0),U,4)="Y") D TRBMSG G:'$D(DUOUT) L7

ENDOPT D UPDATE^AGED,^AGBIC2C:AG("SEL")=3

 G VAR

END K AG,AGCHRT,AGLINE,AGPAT,AGUPDT,DA,DFOUT,DIC,DLOUT,DQOUT,DR,DTOUT,DUOUT,G,AGL,AG("LKDATA"),AG("LKERR"),AG("LKPRINT"),X,Y

 Q

TRBMSG W !,"OLD (unused) TRIBE.",!,"Please enter a current TRIBE name.",!,"""??"" for a list, ""^"" to exit."

 Q

AGBICEDZ  ; IHS/ASDS/EFG - ;  

 +1       ;;7.1;PATIENT REGISTRATION;;AUG 25,2005

 +2        DO PTLK^AG

 +3        IF '$DATA(DFN)

               QUIT 

           DO VIDEO^AG

           SET AG("SVELIG")=""

           IF $DATA(^AUPNPAT(DFN,11))

               SET AG("SVELIG")=$PIECE(^(11),U,24)

 +4        IF '$DATA(^DPT(DFN,0))

               QUIT 

           SET AG("PG")="BICFLDS"

           SET AGPAT=$PIECE(^DPT(DFN,0),U)

           SET AGCHRT=$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2)

           SET AG("AUPN")=""

           IF $DATA(^AUPNPAT(DFN,0))

               SET AG("AUPN")=^(0)

 +5        SET AGUPDT=""

           SET Y=$PIECE(AG("AUPN"),U,3)

           IF Y]""

               DO DD^%DT

               SET AGUPDT="(updated: "_Y_")"

 +6        IF AGUPDT=""

               SET Y=$PIECE(AG("AUPN"),U,2)

               IF Y]""

                   DO DD^%DT

                   SET AGUPDT="(file est: "_Y_")"

 +7        SET AGLINE("-")="W !,""------------------------------------------------------------------------------"""

           SET AGLINE("EQ")="W !,""=============================================================================="""

VAR        DO ^AGBIC2C

           DO ^AGED

           SET DA=DFN

           SET DR=1124

           SET DIC=9000001

           DO ^AGDICLK

           WRITE !!,"IHS ELIGIBILITY : ",AG("LKPRINT"),!!

 +1        WRITE !,"1.       COMMUNITY:"

           IF $DATA(^AUPNPAT(DFN,11))

               WRITE ?22,$PIECE(^(11),U,18)

               IF $PIECE(^(11),U,18)]""

                   WRITE $SELECT($PIECE(^(11),U,21)="Y":" (VERIFIED)",$PIECE(^(11),U,21)="N":" (UNVERIFIED)",1:" (UNVERIFIED)")

 +2        WRITE !,"2.           TRIBE:",?22

           SET AG("Y")=$PIECE(^AUPNPAT(DFN,11),U,8)

 +3        IF AG("Y")]""

               IF $DATA(^AUTTTRI(AG("Y")))

                   WRITE $PIECE(^AUTTTRI(AG("Y"),0),U)

                   IF $PIECE(^(0),U,4)="Y"

                       WRITE ?$X+2,$$S^AGVDF("RVN"),"(OLD UNUSED TRIBE NAME)",$$S^AGVDF("RVF")

 +4        IF $DATA(^AUPNPAT(DFN,11))

               IF $PIECE(^(11),U,8)]""

                   IF $PIECE(^(11),U,19)]""

                       WRITE $SELECT($PIECE(^(11),U,19)="Y":" (VERIFIED)",$PIECE(^(11),U,19)="U":" (UNABLE TO VERIFY (NO TRIBAL ROLE))",1:" (UNVERIFIED)")

 +5        WRITE !,"3.  INDIAN QUANTUM:",?22,$PIECE(^AUPNPAT(DFN,11),U,10),!

           WRITE !,AGLINE("EQ")

 +6        WRITE !!?23,"CHANGE which item? (1-3) NONE// "

           DO READ^AGED1

           IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DFOUT)

               QUIT 

           IF $DATA(DLOUT)!(Y["N")

               GOTO END

           IF $DATA(AG("ERR"))

               GOTO VAR

           IF $DATA(DQOUT)!(+Y<1)!(+Y>3)

               DO QUES^AGED1

               GOTO VAR

 +7        SET AG("SEL")=+Y

L7         DO @($PIECE("EDCOM^AG2B,TRIBE^AG2A,IQTM^AG2A",",",AG("SEL")))

 +1        IF AG("SEL")="1"

               IF '$DATA(AG("COMAGED1"))

                   GOTO VAR

               SET DIE="^AUPNPAT("

               SET DA=DFN

               SET DR="1121///"_AG("COMAGED1")

               DO ^DIE

               DO ^AGBIC2C

               GOTO ENDOPT

 +2        IF AG("SEL")=2&($PIECE(^AUTTTRI($PIECE(^AUPNPAT(DFN,11),U,8),0),U,4)="Y")

               DO TRBMSG

               IF '$DATA(DUOUT)

                   GOTO L7

ENDOPT     DO UPDATE^AGED

           IF AG("SEL")=3

               DO ^AGBIC2C

 +1        GOTO VAR

END        KILL AG,AGCHRT,AGLINE,AGPAT,AGUPDT,DA,DFOUT,DIC,DLOUT,DQOUT,DR,DTOUT,DUOUT,G,AGL,AG("LKDATA"),AG("LKERR"),AG("LKPRINT"),X,Y

 +1        QUIT 

TRBMSG     WRITE !,"OLD (unused) TRIBE.",!,"Please enter a current TRIBE name.",!,"""??"" for a list, ""^"" to exit."

 +1        QUIT