IBJDF8I1 ;ALB/RRG-ADD/EDIT IB DM WORKLOAD PARAMETERS-(CONT.) ;11/06/00
;;2.0;INTEGRATED BILLING;**123**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EDIT ; - Edit existing assignments
;
N IBASDA0,IBASNNUM W !
S DIR("A")="Choose a valid Assignment Number to edit: "
S DIR(0)="LA^1:"_(IBNEWASN-1)_"^K:'$D(IBAS(X)) X"
S DIR("?")="Must be a valid assignment listed above..."
D ^DIR K IBAS I ($D(DTOUT))!($D(DUOUT))!(Y'>0) S IBQUIT=1 L -^IBE(351.73,IBCL) Q
S IBASNNUM=X K DIR,DIROUT,DTOUT,DUOUT,Y
I '$D(^IBE(351.73,IBCL,1,IBASNNUM)) G EDIT
S IBASDA0=$G(^IBE(351.73,IBCL,1,IBASNNUM,0)),IBBCAT=$P(IBASDA0,"^",2)
W !?3,"Bill Category for assignment # "_IBASNNUM_" is "_$P(^PRCA(430.2,IBBCAT,0),"^",1)
S IBFOTP=$$CATTYP^IBJD1(IBBCAT)
;
EDIT1 ; - Add/Edit assignment parameters
;
N IBMINBAL,IBRCFLG
S DIR(0)="351.731,.03",DA(1)=IBCL,DA=IBASNNUM
D ^DIR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 L -^IBE(351.73,IBCL) Q
S IBMINBAL=Y K DIR,DIROUT,DTOUT,DUOUT,Y
S IBRCFLG=$P($G(^IBE(351.73,IBCL,1,IBASNNUM,0)),"^",5)
S DIR(0)="Y",DIR("B")=$S(IBRCFLG=0:"NO",1:"YES")
S DIR("A")="EXCLUDE RECEIVABLES REFERRED TO RC"
S DIR("?")="^S IBOFF=67 D HELP^IBJDF8H"
D ^DIR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 L -^IBE(351.73,IBCL) Q
S IBRCFLG=Y K DIR,DIROUT,DTOUT,DUOUT,Y
S DA(1)=IBCL,DIE="^IBE(351.73,"_DA(1)_",1,",DA=IBASNNUM
S DR=".03///"_IBMINBAL_";.05///"_IBRCFLG D ^DIE K DIE,DR,DA
I IBFOTP="F" D FPEDIT I IBQUIT L -^IBE(351.73,IBCL) Q
I IBFOTP="T" D TPEDIT I IBQUIT L -^IBE(351.73,IBCL) Q
Q
;
FPEDIT ; - First Party edit questions
;
N IBFPDATA,IBSDEF,IBTDEF,IBSN,IBDSLP,IBDEF
S IBFPDATA=$G(^IBE(351.73,IBCL,1,IBASNNUM,1)),IBDSLP=$P(IBFPDATA,"^",1)
S IBDEF=$S(IBDSLP'="":IBDSLP,1:45),DA(1)=IBCL
S DIE="^IBE(351.73,"_DA(1)_",1,",DA=IBASNNUM,DR="1.01//^S X=IBDEF"
D ^DIE K DIE,DA,DR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 Q
;
; - Determine range of patient by name or last 4 of SSN
;
S IBSN=$$SNL() I (IBSN="")!(IBSN="^") S IBQUIT=1 Q
;
I IBSN="N" S IBSDEF=$P(IBFPDATA,"^",2),IBTDEF=$P(IBFPDATA,"^",3)
I IBSN="L" S IBSDEF=$P(IBFPDATA,"^",4),IBTDEF=$P(IBFPDATA,"^",5)
;
PAT S DIR(0)="FO",DIR("A")="START WITH "_$S(IBSN="N":"PATIENT NAME",1:"LAST 4 OF SSN")
S DIR("B")=$S(IBSDEF="":"FIRST",1:IBSDEF)
S DIR("?")="^S IBOFF=33 D HELP^IBJDF8H"
D ^DIR K DIR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 Q
S IBSNF=X I X="FIRST" S IBSNF="@"
S DIR(0)="FO",DIR("A")="GO TO "_$S(IBSN="N":"PATIENT NAME",1:"LAST 4 OF SSN")
S DIR("B")=$S(IBTDEF="":"LAST",1:IBTDEF)
S DIR("?")="^S IBOFF=40 D HELP^IBJDF8H"
D ^DIR K DIR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 Q
S IBSNL=X I X="LAST" S IBSNL="@"
I (IBSNL'="@")&($G(IBSNL)']$G(IBSNF))&($G(IBSNL)'=$G(IBSNF))&(IBSNF'="@") W !!,?3,"* The Go To Patient Name/SSN must follow after the Start With Name/SSN. *",! G PAT
S DA(1)=IBCL,DIE="^IBE(351.73,"_DA(1)_",1,",DA=IBASNNUM
I IBSN="N" S DR="1.02///"_IBSNF_";1.03///"_IBSNL_";1.04///@;1.05///@" D ^DIE
I IBSN="L" S DR="1.04///"_IBSNF_";1.05///"_IBSNL_";1.02///@;1.03///@" D ^DIE
K DIE,DA,DR
L -^IBE(351.73,IBCL)
Q
;
TPEDIT ; - Third Party edit questions
;
N IBTPDATA,IBDSLT,IBDEF
S IBTPDATA=$G(^IBE(351.73,IBCL,1,IBASNNUM,2)),IBDSLT=$P(IBTPDATA,"^",1)
S DA(1)=IBCL,DIE="^IBE(351.73,"_DA(1)_",1,",DA=IBASNNUM
S IBDEF=$S(IBDSLT'="":IBDSLT,1:45),DR="2.01//^S X=IBDEF"
D ^DIE K DIE,DA,DR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 Q
;
TYP ; - Select type of receivables to print
S DIR("A")="TYPE OF RECEIVABLE: "
I $P(IBTPDATA,"^",8) S DIR("B")=$P(IBTPDATA,"^",8)
S DIR(0)="SAX^1:INPATIENT;2:OUTPATIENT;3:PROSTHETICS;4:PHARMACY REFILL;5:ALL RECEIVABLES"
D ^DIR K DIR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 Q
S DA(1)=IBCL,DIE="^IBE(351.73,"_DA(1)_",1,",DA=IBASNNUM,DR="2.08///"_Y
D ^DIE K DIE,DR,DA
K DIROUT,DTOUT,DUOUT,Y
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,IBRF,IBRL,IBSDEF,IBTDEF
ICR S IBSDEF=$P(IBTPDATA,"^",2),IBTDEF=$P(IBTPDATA,"^",3)
S DIR(0)="FO",DIR("A")="START WITH INSURANCE CARRIER"
S DIR("B")=$S(IBSDEF="":"FIRST",1:IBSDEF)
S DIR("?")="^S IBOFF=47 D HELP^IBJDF8H"
D ^DIR K DIR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 Q
S IBRF=X I X="FIRST" S IBRF="@"
S DIR(0)="FO",DIR("A")="GO TO INSURANCE CARRIER"
S DIR("B")=$S(IBTDEF="":"LAST",1:IBTDEF)
S DIR("?")="^S IBOFF=54 D HELP^IBJDF8H"
D ^DIR K DIR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 Q
S IBRL=X I X="LAST" S IBRL="@"
I ($G(IBRL)']$G(IBRF))&($G(IBRL)'=$G(IBRF))&(IBRL'="@") W !!,?3,"* The Go to Insurance Carrier Name must follow after the Start with Insurance Carrier. *",! G ICR
S DA(1)=IBCL,DIE="^IBE(351.73,"_DA(1)_",1,",DA=IBASNNUM
S DR="2.02///"_IBRF_";2.03///"_IBRL D ^DIE K DIE,DR,DA
;
NAM ; - Determine range of patients
;
; - Determine range of patient by name or last 4 of SSN
;
S IBSN=$$SNL() I (IBSN="")!(IBSN="^") S IBQUIT=1 Q
;
I IBSN="N" S IBSDEF=$P(IBTPDATA,"^",4),IBTDEF=$P(IBTPDATA,"^",5)
I IBSN="L" S IBSDEF=$P(IBTPDATA,"^",6),IBTDEF=$P(IBTPDATA,"^",7)
;
NAM1 S DIR(0)="FO",DIR("A")="START WITH "_$S(IBSN="N":"PATIENT NAME",1:"LAST 4 OF SSN")
S DIR("B")=$S(IBSDEF="":"FIRST",1:IBSDEF)
S DIR("?")="^S IBOFF=33 D HELP^IBJDF8H"
D ^DIR K DIR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 Q
S IBSNF=X I X="FIRST" S IBSNF="@"
S DIR(0)="FO",DIR("A")="GO TO "_$S(IBSN="N":"PATIENT NAME",1:"LAST 4 OF SSN")
S DIR("B")=$S(IBTDEF="":"LAST",1:IBTDEF)
S DIR("?")="^S IBOFF=40 D HELP^IBJDF8H"
D ^DIR K DIR I ($D(DTOUT))!($D(DUOUT)) S IBQUIT=1 Q
S IBSNL=X I X="LAST" S IBSNL="@"
I (IBSNL'="@")&($G(IBSNL)']$G(IBSNF))&($G(IBSNL)'=$G(IBSNF))&(IBSNF'="@") W !!,?3,"* The Go To Patient Name/SSN must follow after the Start With Name/SSN. *",! G NAM1
S DA(1)=IBCL,DIE="^IBE(351.73,"_DA(1)_",1,",DA=IBASNNUM
I IBSN="N" S DR="2.04///"_IBSNF_";2.05///"_IBSNL_";2.06///@;2.07///@" D ^DIE
I IBSN="L" S DR="2.06///"_IBSNF_";2.07///"_IBSNL_";2.04///@;2.05///@" D ^DIE
K DIE,DA,DR
;
L -^IBE(351.73,IBCL)
Q
;
SNL() ; - Determine the patient data to be stored-either by Name or
; last 4 SSN
N DIR,DIRUT,DTOUT,DUOUT,DIROUT,IBSN,IBDEF,IBWLDAT
I IBFOTP="F" S IBWLDAT=$G(^IBE(351.73,IBCL,1,IBASNNUM,1)) D
. S IBDEF=$S($P(IBWLDAT,"^",2)'="":"NAME",$P(IBWLDAT,"^",3)'="":"NAME",$P(IBWLDAT,"^",4)'="":"LAST 4",$P(IBWLDAT,"^",5)'="":"LAST 4",1:"")
I IBFOTP="T" S IBWLDAT=$G(^IBE(351.73,IBCL,1,IBASNNUM,2)) D
. S IBDEF=$S($P(IBWLDAT,"^",4)'="":"NAME",$P(IBWLDAT,"^",5)'="":"NAME",$P(IBWLDAT,"^",6)'="":"LAST 4",$P(IBWLDAT,"^",7)'="":"LAST 4",1:"")
S IBSN=""
S DIR(0)="SA^N:NAME;L:LAST 4"
S DIR("A")="Sort Patients by (N)ame or (L)ast 4 of the SSN: "
I IBDEF'="" S DIR("B")=IBDEF
S DIR("?")="^D HNL^IBJD"
W ! D ^DIR K DIR I Y=""!(X="^") Q "^"
S IBSN=Y
Q IBSN
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF8I1 6726 printed Apr 09, 2024@21:22:46 Page 2
IBJDF8I1 ;ALB/RRG-ADD/EDIT IB DM WORKLOAD PARAMETERS-(CONT.) ;11/06/00
+1 ;;2.0;INTEGRATED BILLING;**123**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EDIT ; - Edit existing assignments
+1 ;
+2 NEW IBASDA0,IBASNNUM
WRITE !
+3 SET DIR("A")="Choose a valid Assignment Number to edit: "
+4 SET DIR(0)="LA^1:"_(IBNEWASN-1)_"^K:'$D(IBAS(X)) X"
+5 SET DIR("?")="Must be a valid assignment listed above..."
+6 DO ^DIR
KILL IBAS
IF ($DATA(DTOUT))!($DATA(DUOUT))!(Y'>0)
SET IBQUIT=1
LOCK -^IBE(351.73,IBCL)
QUIT
+7 SET IBASNNUM=X
KILL DIR,DIROUT,DTOUT,DUOUT,Y
+8 IF '$DATA(^IBE(351.73,IBCL,1,IBASNNUM))
GOTO EDIT
+9 SET IBASDA0=$GET(^IBE(351.73,IBCL,1,IBASNNUM,0))
SET IBBCAT=$PIECE(IBASDA0,"^",2)
+10 WRITE !?3,"Bill Category for assignment # "_IBASNNUM_" is "_$PIECE(^PRCA(430.2,IBBCAT,0),"^",1)
+11 SET IBFOTP=$$CATTYP^IBJD1(IBBCAT)
+12 ;
EDIT1 ; - Add/Edit assignment parameters
+1 ;
+2 NEW IBMINBAL,IBRCFLG
+3 SET DIR(0)="351.731,.03"
SET DA(1)=IBCL
SET DA=IBASNNUM
+4 DO ^DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))
SET IBQUIT=1
LOCK -^IBE(351.73,IBCL)
QUIT
+5 SET IBMINBAL=Y
KILL DIR,DIROUT,DTOUT,DUOUT,Y
+6 SET IBRCFLG=$PIECE($GET(^IBE(351.73,IBCL,1,IBASNNUM,0)),"^",5)
+7 SET DIR(0)="Y"
SET DIR("B")=$SELECT(IBRCFLG=0:"NO",1:"YES")
+8 SET DIR("A")="EXCLUDE RECEIVABLES REFERRED TO RC"
+9 SET DIR("?")="^S IBOFF=67 D HELP^IBJDF8H"
+10 DO ^DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))
SET IBQUIT=1
LOCK -^IBE(351.73,IBCL)
QUIT
+11 SET IBRCFLG=Y
KILL DIR,DIROUT,DTOUT,DUOUT,Y
+12 SET DA(1)=IBCL
SET DIE="^IBE(351.73,"_DA(1)_",1,"
SET DA=IBASNNUM
+13 SET DR=".03///"_IBMINBAL_";.05///"_IBRCFLG
DO ^DIE
KILL DIE,DR,DA
+14 IF IBFOTP="F"
DO FPEDIT
IF IBQUIT
LOCK -^IBE(351.73,IBCL)
QUIT
+15 IF IBFOTP="T"
DO TPEDIT
IF IBQUIT
LOCK -^IBE(351.73,IBCL)
QUIT
+16 QUIT
+17 ;
FPEDIT ; - First Party edit questions
+1 ;
+2 NEW IBFPDATA,IBSDEF,IBTDEF,IBSN,IBDSLP,IBDEF
+3 SET IBFPDATA=$GET(^IBE(351.73,IBCL,1,IBASNNUM,1))
SET IBDSLP=$PIECE(IBFPDATA,"^",1)
+4 SET IBDEF=$SELECT(IBDSLP'="":IBDSLP,1:45)
SET DA(1)=IBCL
+5 SET DIE="^IBE(351.73,"_DA(1)_",1,"
SET DA=IBASNNUM
SET DR="1.01//^S X=IBDEF"
+6 DO ^DIE
KILL DIE,DA,DR
IF ($DATA(DTOUT))!($DATA(DUOUT))
SET IBQUIT=1
QUIT
+7 ;
+8 ; - Determine range of patient by name or last 4 of SSN
+9 ;
+10 SET IBSN=$$SNL()
IF (IBSN="")!(IBSN="^")
SET IBQUIT=1
QUIT
+11 ;
+12 IF IBSN="N"
SET IBSDEF=$PIECE(IBFPDATA,"^",2)
SET IBTDEF=$PIECE(IBFPDATA,"^",3)
+13 IF IBSN="L"
SET IBSDEF=$PIECE(IBFPDATA,"^",4)
SET IBTDEF=$PIECE(IBFPDATA,"^",5)
+14 ;
PAT SET DIR(0)="FO"
SET DIR("A")="START WITH "_$SELECT(IBSN="N":"PATIENT NAME",1:"LAST 4 OF SSN")
+1 SET DIR("B")=$SELECT(IBSDEF="":"FIRST",1:IBSDEF)
+2 SET DIR("?")="^S IBOFF=33 D HELP^IBJDF8H"
+3 DO ^DIR
KILL DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))
SET IBQUIT=1
QUIT
+4 SET IBSNF=X
IF X="FIRST"
SET IBSNF="@"
+5 SET DIR(0)="FO"
SET DIR("A")="GO TO "_$SELECT(IBSN="N":"PATIENT NAME",1:"LAST 4 OF SSN")
+6 SET DIR("B")=$SELECT(IBTDEF="":"LAST",1:IBTDEF)
+7 SET DIR("?")="^S IBOFF=40 D HELP^IBJDF8H"
+8 DO ^DIR
KILL DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))
SET IBQUIT=1
QUIT
+9 SET IBSNL=X
IF X="LAST"
SET IBSNL="@"
+10 IF (IBSNL'="@")&($GET(IBSNL)']$GET(IBSNF))&($GET(IBSNL)'=$GET(IBSNF))&(IBSNF'="@")
WRITE !!,?3,"* The Go To Patient Name/SSN must follow after the Start With Name/SSN. *",!
GOTO PAT
+11 SET DA(1)=IBCL
SET DIE="^IBE(351.73,"_DA(1)_",1,"
SET DA=IBASNNUM
+12 IF IBSN="N"
SET DR="1.02///"_IBSNF_";1.03///"_IBSNL_";1.04///@;1.05///@"
DO ^DIE
+13 IF IBSN="L"
SET DR="1.04///"_IBSNF_";1.05///"_IBSNL_";1.02///@;1.03///@"
DO ^DIE
+14 KILL DIE,DA,DR
+15 LOCK -^IBE(351.73,IBCL)
+16 QUIT
+17 ;
TPEDIT ; - Third Party edit questions
+1 ;
+2 NEW IBTPDATA,IBDSLT,IBDEF
+3 SET IBTPDATA=$GET(^IBE(351.73,IBCL,1,IBASNNUM,2))
SET IBDSLT=$PIECE(IBTPDATA,"^",1)
+4 SET DA(1)=IBCL
SET DIE="^IBE(351.73,"_DA(1)_",1,"
SET DA=IBASNNUM
+5 SET IBDEF=$SELECT(IBDSLT'="":IBDSLT,1:45)
SET DR="2.01//^S X=IBDEF"
+6 DO ^DIE
KILL DIE,DA,DR
IF ($DATA(DTOUT))!($DATA(DUOUT))
SET IBQUIT=1
QUIT
+7 ;
TYP ; - Select type of receivables to print
+1 SET DIR("A")="TYPE OF RECEIVABLE: "
+2 IF $PIECE(IBTPDATA,"^",8)
SET DIR("B")=$PIECE(IBTPDATA,"^",8)
+3 SET DIR(0)="SAX^1:INPATIENT;2:OUTPATIENT;3:PROSTHETICS;4:PHARMACY REFILL;5:ALL RECEIVABLES"
+4 DO ^DIR
KILL DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))
SET IBQUIT=1
QUIT
+5 SET DA(1)=IBCL
SET DIE="^IBE(351.73,"_DA(1)_",1,"
SET DA=IBASNNUM
SET DR="2.08///"_Y
+6 DO ^DIE
KILL DIE,DR,DA
+7 KILL DIROUT,DTOUT,DUOUT,Y
+8 ;
+9 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,IBRF,IBRL,IBSDEF,IBTDEF
ICR SET IBSDEF=$PIECE(IBTPDATA,"^",2)
SET IBTDEF=$PIECE(IBTPDATA,"^",3)
+1 SET DIR(0)="FO"
SET DIR("A")="START WITH INSURANCE CARRIER"
+2 SET DIR("B")=$SELECT(IBSDEF="":"FIRST",1:IBSDEF)
+3 SET DIR("?")="^S IBOFF=47 D HELP^IBJDF8H"
+4 DO ^DIR
KILL DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))
SET IBQUIT=1
QUIT
+5 SET IBRF=X
IF X="FIRST"
SET IBRF="@"
+6 SET DIR(0)="FO"
SET DIR("A")="GO TO INSURANCE CARRIER"
+7 SET DIR("B")=$SELECT(IBTDEF="":"LAST",1:IBTDEF)
+8 SET DIR("?")="^S IBOFF=54 D HELP^IBJDF8H"
+9 DO ^DIR
KILL DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))
SET IBQUIT=1
QUIT
+10 SET IBRL=X
IF X="LAST"
SET IBRL="@"
+11 IF ($GET(IBRL)']$GET(IBRF))&($GET(IBRL)'=$GET(IBRF))&(IBRL'="@")
WRITE !!,?3,"* The Go to Insurance Carrier Name must follow after the Start with Insurance Carrier. *",!
GOTO ICR
+12 SET DA(1)=IBCL
SET DIE="^IBE(351.73,"_DA(1)_",1,"
SET DA=IBASNNUM
+13 SET DR="2.02///"_IBRF_";2.03///"_IBRL
DO ^DIE
KILL DIE,DR,DA
+14 ;
NAM ; - Determine range of patients
+1 ;
+2 ; - Determine range of patient by name or last 4 of SSN
+3 ;
+4 SET IBSN=$$SNL()
IF (IBSN="")!(IBSN="^")
SET IBQUIT=1
QUIT
+5 ;
+6 IF IBSN="N"
SET IBSDEF=$PIECE(IBTPDATA,"^",4)
SET IBTDEF=$PIECE(IBTPDATA,"^",5)
+7 IF IBSN="L"
SET IBSDEF=$PIECE(IBTPDATA,"^",6)
SET IBTDEF=$PIECE(IBTPDATA,"^",7)
+8 ;
NAM1 SET DIR(0)="FO"
SET DIR("A")="START WITH "_$SELECT(IBSN="N":"PATIENT NAME",1:"LAST 4 OF SSN")
+1 SET DIR("B")=$SELECT(IBSDEF="":"FIRST",1:IBSDEF)
+2 SET DIR("?")="^S IBOFF=33 D HELP^IBJDF8H"
+3 DO ^DIR
KILL DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))
SET IBQUIT=1
QUIT
+4 SET IBSNF=X
IF X="FIRST"
SET IBSNF="@"
+5 SET DIR(0)="FO"
SET DIR("A")="GO TO "_$SELECT(IBSN="N":"PATIENT NAME",1:"LAST 4 OF SSN")
+6 SET DIR("B")=$SELECT(IBTDEF="":"LAST",1:IBTDEF)
+7 SET DIR("?")="^S IBOFF=40 D HELP^IBJDF8H"
+8 DO ^DIR
KILL DIR
IF ($DATA(DTOUT))!($DATA(DUOUT))
SET IBQUIT=1
QUIT
+9 SET IBSNL=X
IF X="LAST"
SET IBSNL="@"
+10 IF (IBSNL'="@")&($GET(IBSNL)']$GET(IBSNF))&($GET(IBSNL)'=$GET(IBSNF))&(IBSNF'="@")
WRITE !!,?3,"* The Go To Patient Name/SSN must follow after the Start With Name/SSN. *",!
GOTO NAM1
+11 SET DA(1)=IBCL
SET DIE="^IBE(351.73,"_DA(1)_",1,"
SET DA=IBASNNUM
+12 IF IBSN="N"
SET DR="2.04///"_IBSNF_";2.05///"_IBSNL_";2.06///@;2.07///@"
DO ^DIE
+13 IF IBSN="L"
SET DR="2.06///"_IBSNF_";2.07///"_IBSNL_";2.04///@;2.05///@"
DO ^DIE
+14 KILL DIE,DA,DR
+15 ;
+16 LOCK -^IBE(351.73,IBCL)
+17 QUIT
+18 ;
SNL() ; - Determine the patient data to be stored-either by Name or
+1 ; last 4 SSN
+2 NEW DIR,DIRUT,DTOUT,DUOUT,DIROUT,IBSN,IBDEF,IBWLDAT
+3 IF IBFOTP="F"
SET IBWLDAT=$GET(^IBE(351.73,IBCL,1,IBASNNUM,1))
Begin DoDot:1
+4 SET IBDEF=$SELECT($PIECE(IBWLDAT,"^",2)'="":"NAME",$PIECE(IBWLDAT,"^",3)'="":"NAME",$PIECE(IBWLDAT,"^",4)'="":"LAST 4",$PIECE(IBWLDAT,"^",5)'="":"LAST 4",1:"")
End DoDot:1
+5 IF IBFOTP="T"
SET IBWLDAT=$GET(^IBE(351.73,IBCL,1,IBASNNUM,2))
Begin DoDot:1
+6 SET IBDEF=$SELECT($PIECE(IBWLDAT,"^",4)'="":"NAME",$PIECE(IBWLDAT,"^",5)'="":"NAME",$PIECE(IBWLDAT,"^",6)'="":"LAST 4",$PIECE(IBWLDAT,"^",7)'="":"LAST 4",1:"")
End DoDot:1
+7 SET IBSN=""
+8 SET DIR(0)="SA^N:NAME;L:LAST 4"
+9 SET DIR("A")="Sort Patients by (N)ame or (L)ast 4 of the SSN: "
+10 IF IBDEF'=""
SET DIR("B")=IBDEF
+11 SET DIR("?")="^D HNL^IBJD"
+12 WRITE !
DO ^DIR
KILL DIR
IF Y=""!(X="^")
QUIT "^"
+13 SET IBSN=Y
+14 QUIT IBSN
+15 ;
