IBCNINSL ;AITC/TAZ/VAD - GENERAL INSURANCE UTILITIES - LOOKUP ;8/20/20 12:46p.m.
;;2.0;INTEGRATED BILLING;**664,687,737,763**;21-MAR-94;Build 29
;;Per VA Directive 6402, this routine should not be modified.
;
;IB*2.0*664/TAZ/VAD - Cloned code from VAUTOMA to increase functionality
;IB*763/TAZ Removed tag INSCO since it has been replaced by another lookup.
;
; IA #2171 used in tag INSTS
;
;Tags DIVISION, CLINIC, PATIENT, and WARD need to be updated to work with the new functionality in a future patch
DIVISION ;
Q
;S ARRAY="IBUTD",DIC="^DG(40.8,",IBUTNI=2,IBUTSTR="division" G FIRST
;
CLINIC ;
Q
;S DIC="^SC(",DIC("S")="I $P(^(0),U,3)=""C""&'+$P($G(^(""OOS"")),U,1)&'+$P($G(^(""OOS"")),U,2)&$S(IBUTD:1,$D(IBUTD(+$P(^(0),U,15))):1,'+$P(^(0),U,15)&$D(IBUTD(+$O(^DG(40.8,0)))):1,1:0)",IBUTSTR="clinic",ARRAY="IBUTC" G FIRST
;
PATIENT ;
Q
;S DIC="^DPT(",IBUTSTR="patient",ARRAY="IBUTN" K DIC("IGNORE") G FIRST
;
INST(ARRAY,PROMPT) ; Institution/Facility Lookup
;INPUT:
; ARRAY - Results of lookup to be used by calling routine
; PROMPT - Text to be used when prompting for an entry
;
N IBUTNI,FAC
S SCREEN="I $$INSTS^IBCNINSL(+$G(Y))"
D LOOKUP(4,PROMPT,"FAC",1,,.SCREEN)
M ARRAY=FAC
Q
;
INSTS(IEN) ;Screen for Institution IA #2171
;Called by:
; - Instution Lookup INST^IBCNINSL
; - Sending SITE Setup - TFL^IBCNIUF
;Input:
;IEN - Internal Entry Number $G(Y)
;
N ARRAY,OK,PRNT,PSTA,STA
S OK=0
I $$WHAT^XUAF4(IEN,13)'="VAMC" G INSTSQ ;Not a VAMC
S STA=$$STA^XUAF4(IEN) I STA="" G INSTSQ ;No Station Number
I '$$ACTIVE^XUAF4(IEN) G INSTSQ ;Inactive
S PRNT=$$PRNT^XUAF4(STA),PSTA=$P(PRNT,U,2)
S OK=$S(PRNT="":0,PSTA="":1,PSTA=STA:1,1:0)
INSTSQ ;Exit Screen
Q OK
;
PAYER(APP,ARRAY) ;Payer Lookup
;INPUT:
; APP - PAYER APPLICATION to include in lookup
; ARRAY - Results of lookup to be used by calling routine
;
;IB*737/TAZ - Removed references to "~NO PAYER" which was an input parameter
;
N IBUTNI,PAYER,SCREEN
I $G(APP)'="" S SCREEN="I $$PYRAPP^IBCNEUT5("""_APP_""",$G(Y))'="""""
D LOOKUP(365.12,"Payer","PAYER",,,.SCREEN)
M ARRAY=PAYER
Q
;
LOOKUP(FILE,IBPROMPT,ARRAY,IBALL,IBONE,SCREEN) ; Perform a lookup on the selected Dictionary
;variables:
; ARRAY - The array of results of selection. If not defined will return in
; * ^TMP($J,"IBCNINSL",<Uppercased IBPROMPT>)
; * Passed by reference
; You can use a local or global array but a local array may cause problems
; FILE - FILE number for lookup
; IBALL - Prompt for All
; IBPROMPT - Prompt for Dictionary
; IBONE - Return 1 selection
; SCREEN - Filter entries
; * This is set up in the calling subroutine and used. It must be Newed/Killed there.
;
;Get 1st Entry
N DIC,DIR,IBI,QUIT,REMOVE,X,Y
I '$D(ARRAY) S ARRAY=$NA(^TMP($J,"IBCNINSL",$$UP^XLFSTR(IBPROMPT)))
K @ARRAY S (@ARRAY,IBI,QUIT,Y)=0 S IBUTNI=$G(IBUTNI,2)
FIRST S DIR(0)="FAO",DIR("A")="Select "_IBPROMPT_": ",DIR("?")="^D QQ^IBCNINSL" S:$G(IBALL) DIR("B")="ALL"
S DIC=FILE,DIC(0)="BEQZ" S:$G(SCREEN)]"" DIC("S")=SCREEN
D ^DIR K DIR
G ERR:(X="^")!'$T D:X["?" QQ,^DIC G:X="" QUIT I X="ALL",$G(IBALL) S @ARRAY=1 G QUIT
S DIC=FILE,DIC(0)="BEQZ"
I $G(SCREEN)'="" S DIC("S")=SCREEN
S X=Y D ^DIC G:Y'>0 FIRST S IBI=1 D SET
;
I $G(IBONE) G QUIT
S IBALL=0
;
;Prompt for subsequent entries
F IBI=IBI:1 D Q:QUIT
. S REMOVE=0
. S DIR(0)="FAO",DIR("A")="Select another "_IBPROMPT_": ",DIR("?")="^D QQ^IBCNINSL"
. D ^DIR K DIR
. I (X="^")!'$T!(X']"") S QUIT=1 Q
. I X["?" D QQ
. I $E(X)="-" S REMOVE=1,X=$E(X,2,$L(X))
. S DIC=FILE,DIC(0)="BEQZ"
. I $G(SCREEN)'="" S DIC("S")=SCREEN
. D ^DIC I Y'>0 Q
. D SET
;
G QUIT
;
SET ;Set into or remove from ARRAY
N J
I $G(REMOVE) D G SETQ
. S J=$S(IBUTNI=2:+Y,1:$P(Y(0),"^"))
. I '$D(@ARRAY@(J)) W *7,"...not on list...can't remove" Q
. W *7,"...removed from list..."
. K @ARRAY@(J)
I $S($D(@ARRAY@($P(Y(0),U))):1,$D(@ARRAY@(+Y)):1,1:0) W !?3,*7,"You have already selected that ",IBPROMPT,". Try again." G SETQ
I IBUTNI=1 S @ARRAY@($P(Y(0),U))=+Y G SETQ
I IBUTNI=3 S @ARRAY@($P(Y(0,0),U))=+Y G SETQ
S @ARRAY@(+Y)=$P(Y(0),U)
SETQ ;
Q
;
QQ ;Display Help
N DIC,IBJ,IBJ1,PROMPT
S PROMPT=IBPROMPT I "yY"[$E(PROMPT,$L(PROMPT)) S PROMPT=$E(PROMPT,1,$L(PROMPT)-1)_"ies"
W !,"ENTER:"
I $G(IBALL) W !?5,"- ALL (Default) for all ",PROMPT,", or"
W !?5,"- Individual ",IBPROMPT
W !?5,"- RETURN once all ",PROMPT," have been selected"
I $O(@ARRAY@(0))]"" D
. W !?5,"- An entry preceeded by a minus [-] sign to remove that entry from list."
. W !!,"NOTE, you have already selected:"
. S IBJ=0 F IBJ1=0:0 S IBJ=$O(@ARRAY@(IBJ)) Q:IBJ="" W !?8,$S(IBUTNI=1:IBJ,1:@ARRAY@(IBJ))
W !
S DIC=FILE,DIC(0)="BEQZ" S:$G(SCREEN)]"" DIC("S")=SCREEN D ^DIC
Q
;
ERR S Y=-1
QUIT S:'$D(Y) Y=1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNINSL 5065 printed Sep 23, 2025@19:52:09 Page 2
IBCNINSL ;AITC/TAZ/VAD - GENERAL INSURANCE UTILITIES - LOOKUP ;8/20/20 12:46p.m.
+1 ;;2.0;INTEGRATED BILLING;**664,687,737,763**;21-MAR-94;Build 29
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;IB*2.0*664/TAZ/VAD - Cloned code from VAUTOMA to increase functionality
+5 ;IB*763/TAZ Removed tag INSCO since it has been replaced by another lookup.
+6 ;
+7 ; IA #2171 used in tag INSTS
+8 ;
+9 ;Tags DIVISION, CLINIC, PATIENT, and WARD need to be updated to work with the new functionality in a future patch
DIVISION ;
+1 QUIT
+2 ;S ARRAY="IBUTD",DIC="^DG(40.8,",IBUTNI=2,IBUTSTR="division" G FIRST
+3 ;
CLINIC ;
+1 QUIT
+2 ;S DIC="^SC(",DIC("S")="I $P(^(0),U,3)=""C""&'+$P($G(^(""OOS"")),U,1)&'+$P($G(^(""OOS"")),U,2)&$S(IBUTD:1,$D(IBUTD(+$P(^(0),U,15))):1,'+$P(^(0),U,15)&$D(IBUTD(+$O(^DG(40.8,0)))):1,1:0)",IBUTSTR="clinic",ARRAY="IBUTC" G FIRST
+3 ;
PATIENT ;
+1 QUIT
+2 ;S DIC="^DPT(",IBUTSTR="patient",ARRAY="IBUTN" K DIC("IGNORE") G FIRST
+3 ;
INST(ARRAY,PROMPT) ; Institution/Facility Lookup
+1 ;INPUT:
+2 ; ARRAY - Results of lookup to be used by calling routine
+3 ; PROMPT - Text to be used when prompting for an entry
+4 ;
+5 NEW IBUTNI,FAC
+6 SET SCREEN="I $$INSTS^IBCNINSL(+$G(Y))"
+7 DO LOOKUP(4,PROMPT,"FAC",1,,.SCREEN)
+8 MERGE ARRAY=FAC
+9 QUIT
+10 ;
INSTS(IEN) ;Screen for Institution IA #2171
+1 ;Called by:
+2 ; - Instution Lookup INST^IBCNINSL
+3 ; - Sending SITE Setup - TFL^IBCNIUF
+4 ;Input:
+5 ;IEN - Internal Entry Number $G(Y)
+6 ;
+7 NEW ARRAY,OK,PRNT,PSTA,STA
+8 SET OK=0
+9 ;Not a VAMC
IF $$WHAT^XUAF4(IEN,13)'="VAMC"
GOTO INSTSQ
+10 ;No Station Number
SET STA=$$STA^XUAF4(IEN)
IF STA=""
GOTO INSTSQ
+11 ;Inactive
IF '$$ACTIVE^XUAF4(IEN)
GOTO INSTSQ
+12 SET PRNT=$$PRNT^XUAF4(STA)
SET PSTA=$PIECE(PRNT,U,2)
+13 SET OK=$SELECT(PRNT="":0,PSTA="":1,PSTA=STA:1,1:0)
INSTSQ ;Exit Screen
+1 QUIT OK
+2 ;
PAYER(APP,ARRAY) ;Payer Lookup
+1 ;INPUT:
+2 ; APP - PAYER APPLICATION to include in lookup
+3 ; ARRAY - Results of lookup to be used by calling routine
+4 ;
+5 ;IB*737/TAZ - Removed references to "~NO PAYER" which was an input parameter
+6 ;
+7 NEW IBUTNI,PAYER,SCREEN
+8 IF $GET(APP)'=""
SET SCREEN="I $$PYRAPP^IBCNEUT5("""_APP_""",$G(Y))'="""""
+9 DO LOOKUP(365.12,"Payer","PAYER",,,.SCREEN)
+10 MERGE ARRAY=PAYER
+11 QUIT
+12 ;
LOOKUP(FILE,IBPROMPT,ARRAY,IBALL,IBONE,SCREEN) ; Perform a lookup on the selected Dictionary
+1 ;variables:
+2 ; ARRAY - The array of results of selection. If not defined will return in
+3 ; * ^TMP($J,"IBCNINSL",<Uppercased IBPROMPT>)
+4 ; * Passed by reference
+5 ; You can use a local or global array but a local array may cause problems
+6 ; FILE - FILE number for lookup
+7 ; IBALL - Prompt for All
+8 ; IBPROMPT - Prompt for Dictionary
+9 ; IBONE - Return 1 selection
+10 ; SCREEN - Filter entries
+11 ; * This is set up in the calling subroutine and used. It must be Newed/Killed there.
+12 ;
+13 ;Get 1st Entry
+14 NEW DIC,DIR,IBI,QUIT,REMOVE,X,Y
+15 IF '$DATA(ARRAY)
SET ARRAY=$NAME(^TMP($JOB,"IBCNINSL",$$UP^XLFSTR(IBPROMPT)))
+16 KILL @ARRAY
SET (@ARRAY,IBI,QUIT,Y)=0
SET IBUTNI=$GET(IBUTNI,2)
FIRST SET DIR(0)="FAO"
SET DIR("A")="Select "_IBPROMPT_": "
SET DIR("?")="^D QQ^IBCNINSL"
if $GET(IBALL)
SET DIR("B")="ALL"
+1 SET DIC=FILE
SET DIC(0)="BEQZ"
if $GET(SCREEN)]""
SET DIC("S")=SCREEN
+2 DO ^DIR
KILL DIR
+3 if (X="^")!'$TEST
GOTO ERR
if X["?"
DO QQ
DO ^DIC
if X=""
GOTO QUIT
IF X="ALL"
IF $GET(IBALL)
SET @ARRAY=1
GOTO QUIT
+4 SET DIC=FILE
SET DIC(0)="BEQZ"
+5 IF $GET(SCREEN)'=""
SET DIC("S")=SCREEN
+6 SET X=Y
DO ^DIC
if Y'>0
GOTO FIRST
SET IBI=1
DO SET
+7 ;
+8 IF $GET(IBONE)
GOTO QUIT
+9 SET IBALL=0
+10 ;
+11 ;Prompt for subsequent entries
+12 FOR IBI=IBI:1
Begin DoDot:1
+13 SET REMOVE=0
+14 SET DIR(0)="FAO"
SET DIR("A")="Select another "_IBPROMPT_": "
SET DIR("?")="^D QQ^IBCNINSL"
+15 DO ^DIR
KILL DIR
+16 IF (X="^")!'$TEST!(X']"")
SET QUIT=1
QUIT
+17 IF X["?"
DO QQ
+18 IF $EXTRACT(X)="-"
SET REMOVE=1
SET X=$EXTRACT(X,2,$LENGTH(X))
+19 SET DIC=FILE
SET DIC(0)="BEQZ"
+20 IF $GET(SCREEN)'=""
SET DIC("S")=SCREEN
+21 DO ^DIC
IF Y'>0
QUIT
+22 DO SET
End DoDot:1
if QUIT
QUIT
+23 ;
+24 GOTO QUIT
+25 ;
SET ;Set into or remove from ARRAY
+1 NEW J
+2 IF $GET(REMOVE)
Begin DoDot:1
+3 SET J=$SELECT(IBUTNI=2:+Y,1:$PIECE(Y(0),"^"))
+4 IF '$DATA(@ARRAY@(J))
WRITE *7,"...not on list...can't remove"
QUIT
+5 WRITE *7,"...removed from list..."
+6 KILL @ARRAY@(J)
End DoDot:1
GOTO SETQ
+7 IF $SELECT($DATA(@ARRAY@($PIECE(Y(0),U))):1,$DATA(@ARRAY@(+Y)):1,1:0)
WRITE !?3,*7,"You have already selected that ",IBPROMPT,". Try again."
GOTO SETQ
+8 IF IBUTNI=1
SET @ARRAY@($PIECE(Y(0),U))=+Y
GOTO SETQ
+9 IF IBUTNI=3
SET @ARRAY@($PIECE(Y(0,0),U))=+Y
GOTO SETQ
+10 SET @ARRAY@(+Y)=$PIECE(Y(0),U)
SETQ ;
+1 QUIT
+2 ;
QQ ;Display Help
+1 NEW DIC,IBJ,IBJ1,PROMPT
+2 SET PROMPT=IBPROMPT
IF "yY"[$EXTRACT(PROMPT,$LENGTH(PROMPT))
SET PROMPT=$EXTRACT(PROMPT,1,$LENGTH(PROMPT)-1)_"ies"
+3 WRITE !,"ENTER:"
+4 IF $GET(IBALL)
WRITE !?5,"- ALL (Default) for all ",PROMPT,", or"
+5 WRITE !?5,"- Individual ",IBPROMPT
+6 WRITE !?5,"- RETURN once all ",PROMPT," have been selected"
+7 IF $ORDER(@ARRAY@(0))]""
Begin DoDot:1
+8 WRITE !?5,"- An entry preceeded by a minus [-] sign to remove that entry from list."
+9 WRITE !!,"NOTE, you have already selected:"
+10 SET IBJ=0
FOR IBJ1=0:0
SET IBJ=$ORDER(@ARRAY@(IBJ))
if IBJ=""
QUIT
WRITE !?8,$SELECT(IBUTNI=1:IBJ,1:@ARRAY@(IBJ))
End DoDot:1
+11 WRITE !
+12 SET DIC=FILE
SET DIC(0)="BEQZ"
if $GET(SCREEN)]""
SET DIC("S")=SCREEN
DO ^DIC
+13 QUIT
+14 ;
ERR SET Y=-1
QUIT if '$DATA(Y)
SET Y=1
+1 QUIT
+2 ;
