- ABPAPATL ;PRIV-INS PATIENT LOOK-UP UTILITY; [ 07/14/91 8:51 AM ]
- ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- INIT K ABPAT,ABPAHRN,ABPAPSSN,ABPATDFN,ABPAPAT D XIT,DT^DICRW
- ;
- PROMPT W "Select PATIENT NAME: " D
- .K DFOUT,DTOUT,DUOUT,DQOUT,DLOUT
- .R Y:DTIME I '$T W *7 R Y:5 G PROMPT:Y="." I '$T S (DTOUT,Y)="" Q
- .I Y="/.," S (DFOUT,Y)="" Q
- .I Y="" S DLOUT="" Q
- .I Y="^" S (DUOUT,Y)="" Q
- .I Y?1"?".E!(Y["^") S (DQOUT,Y)="" Q
- .Q
- I $D(DTOUT)!$D(DUOUT)!$D(DFOUT)!$D(DLOUT) G XIT
- I $D(DQOUT) S XQH="ABPAPATIENT" D EN^XQH G INIT
- K DIC S DIC="^ABPVAO(",DIC(0)="EZ",X=Y
- I $D(ABPASITE)=1 D
- .S DIC("S")="I $P(^ABPVAO(Y,0),""^"",2)=ABPASITE"
- DIC S D="B" D IX^DIC ;NAME LOOK-UP
- I +Y<1 S D="D" D IX^DIC ;HRN LOOK-UP
- I +Y<1 S D="F" D IX^DIC ;SSN LOOK-UP
- I +Y<1 S D="I" D IX^DIC ;BILL ID LOOK-UP
- I +Y<1 S D="C" D IX^DIC ;DOS LOOK-UP
- I +Y<1 S D="E" D IX^DIC ;OTHER NAME LOOK-UP
- I +Y<1 I $D(ABPAPTN)=1 D
- .K D,ABPAPTN S DIC(0)="ELZ" D ^DIC
- I +Y>0 S (ABPATDFN,DA)=+Y,ABPAPAT=Y(0,0) I +$P(Y,"^",3)=1 D
- .K DIE S DIE="^ABPVAO(",DR=.04 D ^DIE
- I $D(ABPATDFN)'=1 W *7," ??" S ABPATDFN=""
- E S ABPAHRN=$P(^ABPVAO(ABPATDFN,0),"^",3),ABPAPSSN=$P(^(0),"^",4)
- I $D(ABPAPSSN)=1 I $L(ABPAPSSN)=9 D
- .S ABPASSN=$E(ABPAPSSN,1,3)_"-"_$E(ABPAPSSN,4,5)_"-"_$E(ABPAPSSN,6,9)
- .S ABPAPSSN=ABPASSN K ABPASSN
- XIT K DIC,X,Y,DTOUT,DUOUT,DFOUT,DLOUT,DQOUT,XQH,D
- Q
- ABPAPATL ;PRIV-INS PATIENT LOOK-UP UTILITY; [ 07/14/91 8:51 AM ]
- +1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- INIT KILL ABPAT,ABPAHRN,ABPAPSSN,ABPATDFN,ABPAPAT
- DO XIT
- DO DT^DICRW
- +1 ;
- PROMPT WRITE "Select PATIENT NAME: "
- Begin DoDot:1
- +1 KILL DFOUT,DTOUT,DUOUT,DQOUT,DLOUT
- +2 READ Y:DTIME
- IF '$TEST
- WRITE *7
- READ Y:5
- IF Y="."
- GOTO PROMPT
- IF '$TEST
- SET (DTOUT,Y)=""
- QUIT
- +3 IF Y="/.,"
- SET (DFOUT,Y)=""
- QUIT
- +4 IF Y=""
- SET DLOUT=""
- QUIT
- +5 IF Y="^"
- SET (DUOUT,Y)=""
- QUIT
- +6 IF Y?1"?".E!(Y["^")
- SET (DQOUT,Y)=""
- QUIT
- +7 QUIT
- End DoDot:1
- +8 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DFOUT)!$DATA(DLOUT)
- GOTO XIT
- +9 IF $DATA(DQOUT)
- SET XQH="ABPAPATIENT"
- DO EN^XQH
- GOTO INIT
- +10 KILL DIC
- SET DIC="^ABPVAO("
- SET DIC(0)="EZ"
- SET X=Y
- +11 IF $DATA(ABPASITE)=1
- Begin DoDot:1
- +12 SET DIC("S")="I $P(^ABPVAO(Y,0),""^"",2)=ABPASITE"
- End DoDot:1
- DIC ;NAME LOOK-UP
- SET D="B"
- DO IX^DIC
- +1 ;HRN LOOK-UP
- IF +Y<1
- SET D="D"
- DO IX^DIC
- +2 ;SSN LOOK-UP
- IF +Y<1
- SET D="F"
- DO IX^DIC
- +3 ;BILL ID LOOK-UP
- IF +Y<1
- SET D="I"
- DO IX^DIC
- +4 ;DOS LOOK-UP
- IF +Y<1
- SET D="C"
- DO IX^DIC
- +5 ;OTHER NAME LOOK-UP
- IF +Y<1
- SET D="E"
- DO IX^DIC
- +6 IF +Y<1
- IF $DATA(ABPAPTN)=1
- Begin DoDot:1
- +7 KILL D,ABPAPTN
- SET DIC(0)="ELZ"
- DO ^DIC
- End DoDot:1
- +8 IF +Y>0
- SET (ABPATDFN,DA)=+Y
- SET ABPAPAT=Y(0,0)
- IF +$PIECE(Y,"^",3)=1
- Begin DoDot:1
- +9 KILL DIE
- SET DIE="^ABPVAO("
- SET DR=.04
- DO ^DIE
- End DoDot:1
- +10 IF $DATA(ABPATDFN)'=1
- WRITE *7," ??"
- SET ABPATDFN=""
- +11 IF '$TEST
- SET ABPAHRN=$PIECE(^ABPVAO(ABPATDFN,0),"^",3)
- SET ABPAPSSN=$PIECE(^(0),"^",4)
- +12 IF $DATA(ABPAPSSN)=1
- IF $LENGTH(ABPAPSSN)=9
- Begin DoDot:1
- +13 SET ABPASSN=$EXTRACT(ABPAPSSN,1,3)_"-"_$EXTRACT(ABPAPSSN,4,5)_"-"_$EXTRACT(ABPAPSSN,6,9)
- +14 SET ABPAPSSN=ABPASSN
- KILL ABPASSN
- End DoDot:1
- XIT KILL DIC,X,Y,DTOUT,DUOUT,DFOUT,DLOUT,DQOUT,XQH,D
- +1 QUIT
