- 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 Jan 18, 2025@03:17:08 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 ;