ABPAPNE0.m

ABPAPNE0 ;PVT-INS EDIT PATIENT ALIAS'S; [ 05/24/91  9:54 AM ]

 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991

INIT D XIT

 ;

HEAD S ABPA("HD",1)=ABPATLE

 S ABPA("HD",2)="ENTER/EDIT OTHER NAME(S) USED"

 D ^ABPAHD

 ;

FAC K DIC S DIC="^DIC(4,",DIC(0)="AEQZ"

 S DIC("A")="Select PATIENT FACILITY: " W !! D ^DIC I +Y<1 G XIT

 S ABPASITE=+Y

 ;

PAT W !! D ^ABPAPATL

 G:$D(ABPATDFN)'=1 INIT G:+ABPATDFN'>0 PAT

 ;

DISP S $P(ABPAX,"=",80)="",ABPAHRN=$P(^ABPVAO(ABPATDFN,0),"^",3)

 S ABPAL=$E($P(^DIC(4,$P(^ABPVAO(DA,0),U,2),0),U),1,14)

 S $P(ABPAXX,"-",80)=""

 D ^%AUCLS S X="AO PRIVATE INSURANCE SYSTEM - "

 S X=X_"ENTER/EDIT OTHER NAME(S) USED"

 W ?(40-($L(X)/2)),X

 W !,ABPAX,!,"Patient: ",ABPAPAT_"  ("_ABPAHRN_")",?51,"Facility: "

 W $E(ABPAL,1,18),!,ABPAX

 W !!,?22,"...Other names currently on file...",!

 S U="^",DC=1,D0=ABPATDFN K DXS W ! D ^ABPAPNA K DXS

 I +D1>0 D

 .W !,ABPAXX K X

 I +D1'>0 D

 .W ?20,"...no OTHER NAME'S currently on file...",!!,ABPAXX

CONT W ! S DX=0,DY=18 X XY W:IOST["QUME" ! W:$D(ABPARON)=1 @(ABPARON)

 S ABPAMESS="OTHER NAME USED by this patient..."

 S ABPAMESS=ABPAMESS_"format = LNAME,FNAME MI" W ABPAMESS

 W:$D(ABPARON)=1 @(ABPAROFF)

 K DIC,DIE,DA,DR

 S DIE="^ABPVAO(",DA=+ABPATDFN,DR=.015 D ^DIE

 G INIT

 ;

XIT K ABPADDFN,ABPATDFN,ABPADT,ABPADTD,ABPAPAT,D,ABPAX,ABPAFRDT,ABPATODT

 K ABPA,ABPAL,DIC,C,ABPADT,ABPAQKS,ABPAQK,ABPAHRN,DA,J,K,Z,XQH,ABPACSCR

 K ABPAC,ABPAI,ABPAXX,ABPAINS,DIE,DR,ABPAPD,ABPABDT,ABPASITE,DIC,X,Y

 K ABPAMESS

 Q

ABPAPNE0  ;PVT-INS EDIT PATIENT ALIAS'S; [ 05/24/91  9:54 AM ]

 +1       ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991

INIT       DO XIT

 +1       ;

HEAD       SET ABPA("HD",1)=ABPATLE

 +1        SET ABPA("HD",2)="ENTER/EDIT OTHER NAME(S) USED"

 +2        DO ^ABPAHD

 +3       ;

FAC        KILL DIC

           SET DIC="^DIC(4,"

           SET DIC(0)="AEQZ"

 +1        SET DIC("A")="Select PATIENT FACILITY: "

           WRITE !!

           DO ^DIC

           IF +Y<1

               GOTO XIT

 +2        SET ABPASITE=+Y

 +3       ;

PAT        WRITE !!

           DO ^ABPAPATL

 +1        IF $DATA(ABPATDFN)'=1

               GOTO INIT

           IF +ABPATDFN'>0

               GOTO PAT

 +2       ;

DISP       SET $PIECE(ABPAX,"=",80)=""

           SET ABPAHRN=$PIECE(^ABPVAO(ABPATDFN,0),"^",3)

 +1        SET ABPAL=$EXTRACT($PIECE(^DIC(4,$PIECE(^ABPVAO(DA,0),U,2),0),U),1,14)

 +2        SET $PIECE(ABPAXX,"-",80)=""

 +3        DO ^%AUCLS

           SET X="AO PRIVATE INSURANCE SYSTEM - "

 +4        SET X=X_"ENTER/EDIT OTHER NAME(S) USED"

 +5        WRITE ?(40-($LENGTH(X)/2)),X

 +6        WRITE !,ABPAX,!,"Patient: ",ABPAPAT_"  ("_ABPAHRN_")",?51,"Facility: "

 +7        WRITE $EXTRACT(ABPAL,1,18),!,ABPAX

 +8        WRITE !!,?22,"...Other names currently on file...",!

 +9        SET U="^"

           SET DC=1

           SET D0=ABPATDFN

           KILL DXS

           WRITE !

           DO ^ABPAPNA

           KILL DXS

 +10       IF +D1>0

               Begin DoDot:1

 +11               WRITE !,ABPAXX

                   KILL X

               End DoDot:1

 +12       IF +D1'>0

               Begin DoDot:1

 +13               WRITE ?20,"...no OTHER NAME'S currently on file...",!!,ABPAXX

               End DoDot:1

CONT       WRITE !

           SET DX=0

           SET DY=18

           XECUTE XY

           IF IOST["QUME"

               WRITE !

           IF $DATA(ABPARON)=1

               WRITE @(ABPARON)

 +1        SET ABPAMESS="OTHER NAME USED by this patient..."

 +2        SET ABPAMESS=ABPAMESS_"format = LNAME,FNAME MI"

           WRITE ABPAMESS

 +3        IF $DATA(ABPARON)=1

               WRITE @(ABPAROFF)

 +4        KILL DIC,DIE,DA,DR

 +5        SET DIE="^ABPVAO("

           SET DA=+ABPATDFN

           SET DR=.015

           DO ^DIE

 +6        GOTO INIT

 +7       ;

XIT        KILL ABPADDFN,ABPATDFN,ABPADT,ABPADTD,ABPAPAT,D,ABPAX,ABPAFRDT,ABPATODT

 +1        KILL ABPA,ABPAL,DIC,C,ABPADT,ABPAQKS,ABPAQK,ABPAHRN,DA,J,K,Z,XQH,ABPACSCR

 +2        KILL ABPAC,ABPAI,ABPAXX,ABPAINS,DIE,DR,ABPAPD,ABPABDT,ABPASITE,DIC,X,Y

 +3        KILL ABPAMESS

 +4        QUIT