AG8B.m

AG8B ; IHS/ASDS/EFG - NEXT OF KIN DATA ENTRY ;  

 ;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007

NKNAME ;EP - NOK NAME

NAME1 W !!,"Name of NEXT-OF-KIN (NOK).",!,"  (if same as Emerg. Contact, enter SAME): " D NAMED W:$D(AG("EMNM")) AG("EMNM"),"// "

 D READ^AG Q:$D(DUOUT)!$D(DFOUT)!$D(DTOUT)!$D(DLOUT)  G QUES:$D(DQOUT),SAME:Y="SAME"

 D S2

 S DR=".211///"_Y

 D ^DIE G NAME1:$D(Y)

 ;I $P(^DPT(DFN,.21),U,2)="" S $P(^AUPNPAT(DFN,28),U,2)=""

 I $P($G(^DPT(DFN,.21)),U,2)="" S $P(^AUPNPAT(DFN,28),U,2)=""  ;AG*7.1*2 FOUND DURING ALPHA

 Q

NKREL ;EP - NOK RELATIONSHIP

 D S1 S DR=2802 G END

NKSTR ;EP - NOK STREET

 D S2 S DR=.213 G END

NKCITY ;EP - NOK CITY

 D S2 S DR=.216 G END

NKST ;EP - NOK STATE

 D S2 S DR=.217 G END

NKZIP ;EP - NOK ZIP

 D S2

 I $D(DPTFLAG) S DR=.2207

 E  S DR=.218

 G END

NKPH ;EP - NOK PHONE #

 D S2 S DR=.219 G END

S1 K DUOUT S DIE="^AUPNPAT(",DA=DFN W ! Q

S2 K DUOUT S DIE="^DPT(",DA=DFN W ! Q

END D ^DIE S:$D(Y) DUOUT="" Q

QUES W !!,"Enter the next-of-kin's full name.",!! G NKNAME

NAMED K AG("EMNM") I $D(^DPT(DFN,.21)),$P(^DPT(DFN,.21),U)]"" S AG("EMNM")=$P(^DPT(DFN,.21),U)

 Q

SAME I $D(^DPT(DFN,.33)),$P(^DPT(DFN,.33),U)]"" G SAME1

 W !!,*7,"EMERGENCY CONTACT NOT ON FILE.",! G NKNAME

SAME1 ;

 F I=1:1:10 S AGS(I)=$P(^DPT(DFN,.33),"^",I)

 S AGDR(1)=".211///"_AGS(1)_";.212///"_AGS(2)_";.213///"_AGS(3)_";.214///"_AGS(4)_";.215///"_AGS(5)

 S AGDR(2)=".216///"_AGS(6)_";.217///`"_AGS(7)_";.218///"_AGS(8)_";.219///"_AGS(9)_";.2125////"_AGS(10)

 K DR,DIC S DA=DFN,DR=AGDR(1),DIE="^DPT(" D ^DIE

 K DR,DIC S DA=DFN,DR=AGDR(2),DIE="^DPT(" D ^DIE

 K AGS,AGDR

 I $D(^AUPNPAT(DFN,31)) S DA=DFN,DIE="^AUPNPAT(",DR="2802////"_$P(^AUPNPAT(DFN,31),U,2) K DIC D ^DIE

 Q

NKRELD ;CALLED FROM DGDDC RTN WHICH IS CALLED BY XREF ON FIELD .211 OF ^DPT

 I '$D(XDRMRG) S $P(^AUPNPAT(DA,28),"^",2)=""

 Q

AG8B      ; IHS/ASDS/EFG - NEXT OF KIN DATA ENTRY ;  

 +1       ;;7.1;PATIENT REGISTRATION;**2**;JAN 31, 2007

NKNAME    ;EP - NOK NAME

NAME1      WRITE !!,"Name of NEXT-OF-KIN (NOK).",!,"  (if same as Emerg. Contact, enter SAME): "

           DO NAMED

           IF $DATA(AG("EMNM"))

               WRITE AG("EMNM"),"// "

 +1        DO READ^AG

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

               QUIT 

           IF $DATA(DQOUT)

               GOTO QUES

           IF Y="SAME"

               GOTO SAME

 +2        DO S2

 +3        SET DR=".211///"_Y

 +4        DO ^DIE

           IF $DATA(Y)

               GOTO NAME1

 +5       ;I $P(^DPT(DFN,.21),U,2)="" S $P(^AUPNPAT(DFN,28),U,2)=""

 +6       ;AG*7.1*2 FOUND DURING ALPHA

           IF $PIECE($GET(^DPT(DFN,.21)),U,2)=""

               SET $PIECE(^AUPNPAT(DFN,28),U,2)=""

 +7        QUIT 

NKREL     ;EP - NOK RELATIONSHIP

 +1        DO S1

           SET DR=2802

           GOTO END

NKSTR     ;EP - NOK STREET

 +1        DO S2

           SET DR=.213

           GOTO END

NKCITY    ;EP - NOK CITY

 +1        DO S2

           SET DR=.216

           GOTO END

NKST      ;EP - NOK STATE

 +1        DO S2

           SET DR=.217

           GOTO END

NKZIP     ;EP - NOK ZIP

 +1        DO S2

 +2        IF $DATA(DPTFLAG)

               SET DR=.2207

 +3       IF '$TEST

               SET DR=.218

 +4        GOTO END

NKPH      ;EP - NOK PHONE #

 +1        DO S2

           SET DR=.219

           GOTO END

S1         KILL DUOUT

           SET DIE="^AUPNPAT("

           SET DA=DFN

           WRITE !

           QUIT 

S2         KILL DUOUT

           SET DIE="^DPT("

           SET DA=DFN

           WRITE !

           QUIT 

END        DO ^DIE

           IF $DATA(Y)

               SET DUOUT=""

           QUIT 

QUES       WRITE !!,"Enter the next-of-kin's full name.",!!

           GOTO NKNAME

NAMED      KILL AG("EMNM")

           IF $DATA(^DPT(DFN,.21))

               IF $PIECE(^DPT(DFN,.21),U)]""

                   SET AG("EMNM")=$PIECE(^DPT(DFN,.21),U)

 +1        QUIT 

SAME       IF $DATA(^DPT(DFN,.33))

               IF $PIECE(^DPT(DFN,.33),U)]""

                   GOTO SAME1

 +1        WRITE !!,*7,"EMERGENCY CONTACT NOT ON FILE.",!

           GOTO NKNAME

SAME1     ;

 +1        FOR I=1:1:10

               SET AGS(I)=$PIECE(^DPT(DFN,.33),"^",I)

 +2        SET AGDR(1)=".211///"_AGS(1)_";.212///"_AGS(2)_";.213///"_AGS(3)_";.214///"_AGS(4)_";.215///"_AGS(5)

 +3        SET AGDR(2)=".216///"_AGS(6)_";.217///`"_AGS(7)_";.218///"_AGS(8)_";.219///"_AGS(9)_";.2125////"_AGS(10)

 +4        KILL DR,DIC

           SET DA=DFN

           SET DR=AGDR(1)

           SET DIE="^DPT("

           DO ^DIE

 +5        KILL DR,DIC

           SET DA=DFN

           SET DR=AGDR(2)

           SET DIE="^DPT("

           DO ^DIE

 +6        KILL AGS,AGDR

 +7        IF $DATA(^AUPNPAT(DFN,31))

               SET DA=DFN

               SET DIE="^AUPNPAT("

               SET DR="2802////"_$PIECE(^AUPNPAT(DFN,31),U,2)

               KILL DIC

               DO ^DIE

 +8        QUIT 

NKRELD    ;CALLED FROM DGDDC RTN WHICH IS CALLED BY XREF ON FIELD .211 OF ^DPT

 +1        IF '$DATA(XDRMRG)

               SET $PIECE(^AUPNPAT(DA,28),"^",2)=""

 +2        QUIT