- 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
