AGBIC2B.m

AGBIC2B ; IHS/ASDS/EFG - ENTER CURRENT COMMUNITY ;  

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

 ;

L1 ;

 K AG("HSDA"),AG("PRVCM"),AG("COMM")

 W !!,"Enter PRESENT COMMUNITY: "

 D DEF

 D READ^AG

 G:$D(DUOUT)!$D(DTOUT)!$D(DFOUT) END

 I $D(DLOUT)&($D(AG("EDIT")))&($D(AG("PRVCM"))) D  G L2

 . S Y=AG("PRVCM")

 I $D(DLOUT)!$D(DQOUT) S Y="?"

L2 ;

 S DIC="^AUTTCOM("

 S DIC(0)="QEM"

 S X=Y

 D ^DIC

 G L1:Y<0

 S AG("CPTR")=+Y

 S AG("CITY")=$P(Y,U,2)

 S:$P(^AUTTCTY($P(^AUTTCOM($P(Y,U),0),U,2),0),U,5)="Y" AG("HSDA")="Y"

L3 ;

 K AG("EDIT"),AG("BIRTH"),AG("PRVDT")

 W !!,"When did the patient move to this community?  "

 W "( ""B"" = ""at BIRTH"" ) ",!,"   DATE: "

 D DEF1

 D READ^AG

 Q:$D(DTOUT)!$D(DFOUT)

 G L1:$D(DUOUT)

 I $D(DLOUT)&($D(AG("EDIT")))&($D(AG("PRVDT"))) D  G L3A

 . S Y=AG("PRVDT")

 I $D(DLOUT)!$D(DQOUT) S Y="?"

L3A ;

 I Y="B" D

 . S AG("BIRTH")=""

 . S DIC=2

 . S DA=DFN

 . S DR=.03

 . D ^DIC

 . S:$D(AG("LKDATA")) Y=AG("LKDATA")

 . I $D(AG("LKERR"))!($D(AG("LKDATA"))&(+Y<99999)) D

 .. W !,*7,"There is no DATE-OF-BIRTH on file.",!

 .. S Y="?"

 .. K AG("BIRTH")

 S X=Y

 S %DT=""

 S %DT(0)="-NOW"

 D ^%DT

 K %DT(0)

 G L1:X="^"

 G END:$D(AG("EDIT"))&(X="")

 G L3:Y<0

 S AG("CDATE")=Y

L4 ;

 K ^AUPNPAT(DFN,51)

 S ^AUPNPAT(DFN,51,0)="^9000001.51D^"_AG("CDATE")_"^1"

 S ^AUPNPAT(DFN,51,AG("CDATE"),0)=AG("CDATE")_U_DT_U_AG("CPTR")

 S DIE="^AUPNPAT("

 S DA=DFN

 S DR="1118///"_AG("CITY")

 D ^DIE

CKHSDA ;

 S AG("COMM")="N"

 G STCOMVER:'$D(AG("HSDA"))

 D COMMVER

 G:$D(DUOUT) L3

 I (Y'["Y")&(Y'["N") D  G CKHSDA

 . D YN^AG

 S AG("COMM")=Y

STCOMVER ;

 D S1

 S DR="1121///"_AG("COMM")

 D ^DIE

 G END:AG("COMM")="Y"

CKPREV ;

 G END:$D(AG("BIRTH"))

 G END:AG("CDATE")>"2880915"

 W !!,"This patient's CURRENT COMMUNITY is "

 W $S('$D(AG("HSDA")):"not within a HSDA!",1:"within a HSDA but is not verified!")

MSG1 ;

 W !,"Enter any other COMMUNITY lived in since 09/16/88:  "

 S AG("COMM")="N"

 S AG("2BPREV")=""

 D READ^AG

 G:$D(DUOUT)!$D(DTOUT)!$D(DFOUT) END

 K AG("2BPREV")

 S DIC="^AUTTCOM("

 S DIC(0)="QEM"

 S X=Y

 D ^DIC

 G END:Y<0

 I $P(^AUTTCTY($P(^AUTTCOM($P(Y,U),0),U,2),0),U,5)'="Y" D  G MSG1

 . W !!,$P(^AUTTCOM($P(Y,U),0),U)," is not within a HSDA!"

CKPRVER ;

 D COMMVER

 G:$D(DUOUT)!(Y["N") CKPREV

 I Y'["Y" D  G CKPRVER

 . D YN^AG

 S AG("COMM")="Y"

SETPRV ;

 D S1

 S DR="1122///"_AG("COMM")

 D ^DIE

 G END

END ;

 K AG("COMMVER"),AG("BIRTH"),AG("HSDA"),AG("PRVDT"),AG("PRVCM")

 K AG("COMM"),DIC

 Q

DEF ;

 K AG("EDIT")

 Q:'$D(^AUPNPAT(DFN,51,0))

 S AG("CDATE")=$P(^AUPNPAT(DFN,51,0),U,3)

 Q:AG("CDATE")=""

 Q:'$D(^AUPNPAT(DFN,51,AG("CDATE")))

 S AG("CPTR")=$P(^AUPNPAT(DFN,51,AG("CDATE"),0),U,3)

 Q:+AG("CPTR")<1

 Q:'$D(^AUTTCOM(AG("CPTR")))

 W $P(^AUTTCOM(AG("CPTR"),0),U),"//"

 S AG("EDIT")=""

 S AG("PRVCM")=$P(^AUTTCOM(AG("CPTR"),0),U)

 Q

DEF1 ;

 K AG("EDIT")

 I $D(^AUPNPAT(DFN,51,0)),AG("CDATE")]"" D

 . S Y=$P(^AUPNPAT(DFN,51,AG("CDATE"),0),U)

 . D DD^%DT

 . W !,Y,"// "

 . S AG("EDIT")=""

 . S AG("PRVDT")=Y

 Q

EDCOM ;EP - Edit Communities.

E1 ;

 K DIC("S")

 S DIC=9000001.51

 S DR=.01

 S X=DFN

 D ^DIC

 S DA=+Y

 S DIE="^AUPNPAT("

 S DR=5101

 S DR(2,9000001.51)=".01;.03;S $P(^AUPNPAT(DFN,51,D1,0),U,2)=$P(^AUPNPAT(DFN,51,D1,0),U)"

 D ^DIE

E2 ;

 S AG("DRENT")=0

 S DR=.03

 S AG("CITY")=""

 S DIC=9000001.51

 S DA=DFN

 D ^DIC

 I $D(AG("LKDATA")),AG("LKDATA")]"",$D(^AUTTCOM(AG("LKDATA"))) D  Q:$D(AG("2BPREV"))

 .S (AG("CITY"),AG("2BPREV"))=$P(^AUTTCOM(AG("LKDATA"),0),U)

 .S AG("HSDA")=$P(^AUTTCOM(AG("LKDATA"),0),U,11)

 S DIE="^AUPNPAT("

 S DA=DFN

 S DR="1118///"_AG("CITY")

 D ^DIE

 Q

S1 ;

 K DFOUT,DTOUT,DUOUT,DLOUT,DQOUT

 Q

COMMVER ;EP

 S AG("COMMVER")=" "

 S:$D(^AUPNPAT(DFN,11)) AG("COMMVER")=$P(^AUPNPAT(DFN,11),U,21)

 W !!,"Has this COMMUNITY been VERIFIED? (Y/N): "

 W:(AG("COMMVER")["Y")!(AG("COMMVER")["N") AG("COMMVER")," // "

 D READ^AG

 S:$D(DLOUT)&(AG("COMMVER")'=" ") Y=AG("COMMVER")

 S AG("COMAGED1")=Y

 I "YC"[AGOPT(14),$D(AG("SEL")),AG("SEL")="6" D

 . S DIE="^AUPNPAT("

 . S DA=DFN

 . S DR="1121///"_AG("COMAGED1")

 . D ^DIE

 . D ^AGBIC2C

 Q

AGBIC2B   ; IHS/ASDS/EFG - ENTER CURRENT COMMUNITY ;  

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

 +2       ;

L1        ;

 +1        KILL AG("HSDA"),AG("PRVCM"),AG("COMM")

 +2        WRITE !!,"Enter PRESENT COMMUNITY: "

 +3        DO DEF

 +4        DO READ^AG

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

               GOTO END

 +6        IF $DATA(DLOUT)&($DATA(AG("EDIT")))&($DATA(AG("PRVCM")))

               Begin DoDot:1

 +7                SET Y=AG("PRVCM")

               End DoDot:1

               GOTO L2

 +8        IF $DATA(DLOUT)!$DATA(DQOUT)

               SET Y="?"

L2        ;

 +1        SET DIC="^AUTTCOM("

 +2        SET DIC(0)="QEM"

 +3        SET X=Y

 +4        DO ^DIC

 +5        IF Y<0

               GOTO L1

 +6        SET AG("CPTR")=+Y

 +7        SET AG("CITY")=$PIECE(Y,U,2)

 +8        IF $PIECE(^AUTTCTY($PIECE(^AUTTCOM($PIECE(Y,U),0),U,2),0),U,5)="Y"

               SET AG("HSDA")="Y"

L3        ;

 +1        KILL AG("EDIT"),AG("BIRTH"),AG("PRVDT")

 +2        WRITE !!,"When did the patient move to this community?  "

 +3        WRITE "( ""B"" = ""at BIRTH"" ) ",!,"   DATE: "

 +4        DO DEF1

 +5        DO READ^AG

 +6        IF $DATA(DTOUT)!$DATA(DFOUT)

               QUIT 

 +7        IF $DATA(DUOUT)

               GOTO L1

 +8        IF $DATA(DLOUT)&($DATA(AG("EDIT")))&($DATA(AG("PRVDT")))

               Begin DoDot:1

 +9                SET Y=AG("PRVDT")

               End DoDot:1

               GOTO L3A

 +10       IF $DATA(DLOUT)!$DATA(DQOUT)

               SET Y="?"

L3A       ;

 +1        IF Y="B"

               Begin DoDot:1

 +2                SET AG("BIRTH")=""

 +3                SET DIC=2

 +4                SET DA=DFN

 +5                SET DR=.03

 +6                DO ^DIC

 +7                IF $DATA(AG("LKDATA"))

                       SET Y=AG("LKDATA")

 +8                IF $DATA(AG("LKERR"))!($DATA(AG("LKDATA"))&(+Y<99999))

                       Begin DoDot:2

 +9                        WRITE !,*7,"There is no DATE-OF-BIRTH on file.",!

 +10                       SET Y="?"

 +11                       KILL AG("BIRTH")

                       End DoDot:2

               End DoDot:1

 +12       SET X=Y

 +13       SET %DT=""

 +14       SET %DT(0)="-NOW"

 +15       DO ^%DT

 +16       KILL %DT(0)

 +17       IF X="^"

               GOTO L1

 +18       IF $DATA(AG("EDIT"))&(X="")

               GOTO END

 +19       IF Y<0

               GOTO L3

 +20       SET AG("CDATE")=Y

L4        ;

 +1        KILL ^AUPNPAT(DFN,51)

 +2        SET ^AUPNPAT(DFN,51,0)="^9000001.51D^"_AG("CDATE")_"^1"

 +3        SET ^AUPNPAT(DFN,51,AG("CDATE"),0)=AG("CDATE")_U_DT_U_AG("CPTR")

 +4        SET DIE="^AUPNPAT("

 +5        SET DA=DFN

 +6        SET DR="1118///"_AG("CITY")

 +7        DO ^DIE

CKHSDA    ;

 +1        SET AG("COMM")="N"

 +2        IF '$DATA(AG("HSDA"))

               GOTO STCOMVER

 +3        DO COMMVER

 +4        IF $DATA(DUOUT)

               GOTO L3

 +5        IF (Y'["Y")&(Y'["N")

               Begin DoDot:1

 +6                DO YN^AG

               End DoDot:1

               GOTO CKHSDA

 +7        SET AG("COMM")=Y

STCOMVER  ;

 +1        DO S1

 +2        SET DR="1121///"_AG("COMM")

 +3        DO ^DIE

 +4        IF AG("COMM")="Y"

               GOTO END

CKPREV    ;

 +1        IF $DATA(AG("BIRTH"))

               GOTO END

 +2        IF AG("CDATE")>"2880915"

               GOTO END

 +3        WRITE !!,"This patient's CURRENT COMMUNITY is "

 +4        WRITE $SELECT('$DATA(AG("HSDA")):"not within a HSDA!",1:"within a HSDA but is not verified!")

MSG1      ;

 +1        WRITE !,"Enter any other COMMUNITY lived in since 09/16/88:  "

 +2        SET AG("COMM")="N"

 +3        SET AG("2BPREV")=""

 +4        DO READ^AG

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

               GOTO END

 +6        KILL AG("2BPREV")

 +7        SET DIC="^AUTTCOM("

 +8        SET DIC(0)="QEM"

 +9        SET X=Y

 +10       DO ^DIC

 +11       IF Y<0

               GOTO END

 +12       IF $PIECE(^AUTTCTY($PIECE(^AUTTCOM($PIECE(Y,U),0),U,2),0),U,5)'="Y"

               Begin DoDot:1

 +13               WRITE !!,$PIECE(^AUTTCOM($PIECE(Y,U),0),U)," is not within a HSDA!"

               End DoDot:1

               GOTO MSG1

CKPRVER   ;

 +1        DO COMMVER

 +2        IF $DATA(DUOUT)!(Y["N")

               GOTO CKPREV

 +3        IF Y'["Y"

               Begin DoDot:1

 +4                DO YN^AG

               End DoDot:1

               GOTO CKPRVER

 +5        SET AG("COMM")="Y"

SETPRV    ;

 +1        DO S1

 +2        SET DR="1122///"_AG("COMM")

 +3        DO ^DIE

 +4        GOTO END

END       ;

 +1        KILL AG("COMMVER"),AG("BIRTH"),AG("HSDA"),AG("PRVDT"),AG("PRVCM")

 +2        KILL AG("COMM"),DIC

 +3        QUIT 

DEF       ;

 +1        KILL AG("EDIT")

 +2        IF '$DATA(^AUPNPAT(DFN,51,0))

               QUIT 

 +3        SET AG("CDATE")=$PIECE(^AUPNPAT(DFN,51,0),U,3)

 +4        IF AG("CDATE")=""

               QUIT 

 +5        IF '$DATA(^AUPNPAT(DFN,51,AG("CDATE")))

               QUIT 

 +6        SET AG("CPTR")=$PIECE(^AUPNPAT(DFN,51,AG("CDATE"),0),U,3)

 +7        IF +AG("CPTR")<1

               QUIT 

 +8        IF '$DATA(^AUTTCOM(AG("CPTR")))

               QUIT 

 +9        WRITE $PIECE(^AUTTCOM(AG("CPTR"),0),U),"//"

 +10       SET AG("EDIT")=""

 +11       SET AG("PRVCM")=$PIECE(^AUTTCOM(AG("CPTR"),0),U)

 +12       QUIT 

DEF1      ;

 +1        KILL AG("EDIT")

 +2        IF $DATA(^AUPNPAT(DFN,51,0))

               IF AG("CDATE")]""

                   Begin DoDot:1

 +3                    SET Y=$PIECE(^AUPNPAT(DFN,51,AG("CDATE"),0),U)

 +4                    DO DD^%DT

 +5                    WRITE !,Y,"// "

 +6                    SET AG("EDIT")=""

 +7                    SET AG("PRVDT")=Y

                   End DoDot:1

 +8        QUIT 

EDCOM     ;EP - Edit Communities.

E1        ;

 +1        KILL DIC("S")

 +2        SET DIC=9000001.51

 +3        SET DR=.01

 +4        SET X=DFN

 +5        DO ^DIC

 +6        SET DA=+Y

 +7        SET DIE="^AUPNPAT("

 +8        SET DR=5101

 +9        SET DR(2,9000001.51)=".01;.03;S $P(^AUPNPAT(DFN,51,D1,0),U,2)=$P(^AUPNPAT(DFN,51,D1,0),U)"

 +10       DO ^DIE

E2        ;

 +1        SET AG("DRENT")=0

 +2        SET DR=.03

 +3        SET AG("CITY")=""

 +4        SET DIC=9000001.51

 +5        SET DA=DFN

 +6        DO ^DIC

 +7        IF $DATA(AG("LKDATA"))

               IF AG("LKDATA")]""

                   IF $DATA(^AUTTCOM(AG("LKDATA")))

                       Begin DoDot:1

 +8                        SET (AG("CITY"),AG("2BPREV"))=$PIECE(^AUTTCOM(AG("LKDATA"),0),U)

 +9                        SET AG("HSDA")=$PIECE(^AUTTCOM(AG("LKDATA"),0),U,11)

                       End DoDot:1

                       IF $DATA(AG("2BPREV"))

                           QUIT 

 +10       SET DIE="^AUPNPAT("

 +11       SET DA=DFN

 +12       SET DR="1118///"_AG("CITY")

 +13       DO ^DIE

 +14       QUIT 

S1        ;

 +1        KILL DFOUT,DTOUT,DUOUT,DLOUT,DQOUT

 +2        QUIT 

COMMVER   ;EP

 +1        SET AG("COMMVER")=" "

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

               SET AG("COMMVER")=$PIECE(^AUPNPAT(DFN,11),U,21)

 +3        WRITE !!,"Has this COMMUNITY been VERIFIED? (Y/N): "

 +4        IF (AG("COMMVER")["Y")!(AG("COMMVER")["N")

               WRITE AG("COMMVER")," // "

 +5        DO READ^AG

 +6        IF $DATA(DLOUT)&(AG("COMMVER")'=" ")

               SET Y=AG("COMMVER")

 +7        SET AG("COMAGED1")=Y

 +8        IF "YC"[AGOPT(14)

               IF $DATA(AG("SEL"))

                   IF AG("SEL")="6"

                       Begin DoDot:1

 +9                        SET DIE="^AUPNPAT("

 +10                       SET DA=DFN

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

 +12                       DO ^DIE

 +13                       DO ^AGBIC2C

                       End DoDot:1

 +14       QUIT