- 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