Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCNINSL

IBCNINSL.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;IB*2.0*664/TAZ/VAD - Cloned code from VAUTOMA to increase functionality
  1. ;IB*763/TAZ Removed tag INSCO since it has been replaced by another lookup.
  1. ;
  1. ; IA #2171 used in tag INSTS
  1. ;
  1. ;Tags DIVISION, CLINIC, PATIENT, and WARD need to be updated to work with the new functionality in a future patch
  1. DIVISION ;
  1. Q
  1. ;S ARRAY="IBUTD",DIC="^DG(40.8,",IBUTNI=2,IBUTSTR="division" G FIRST
  1. ;
  1. CLINIC ;
  1. Q
  1. ;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
  1. ;
  1. PATIENT ;
  1. Q
  1. ;S DIC="^DPT(",IBUTSTR="patient",ARRAY="IBUTN" K DIC("IGNORE") G FIRST
  1. ;
  1. INST(ARRAY,PROMPT) ; Institution/Facility Lookup
  1. ;INPUT:
  1. ; ARRAY - Results of lookup to be used by calling routine
  1. ; PROMPT - Text to be used when prompting for an entry
  1. ;
  1. N IBUTNI,FAC
  1. S SCREEN="I $$INSTS^IBCNINSL(+$G(Y))"
  1. D LOOKUP(4,PROMPT,"FAC",1,,.SCREEN)
  1. M ARRAY=FAC
  1. Q
  1. ;
  1. INSTS(IEN) ;Screen for Institution IA #2171
  1. ;Called by:
  1. ; - Instution Lookup INST^IBCNINSL
  1. ; - Sending SITE Setup - TFL^IBCNIUF
  1. ;Input:
  1. ;IEN - Internal Entry Number $G(Y)
  1. ;
  1. N ARRAY,OK,PRNT,PSTA,STA
  1. S OK=0
  1. I $$WHAT^XUAF4(IEN,13)'="VAMC" G INSTSQ ;Not a VAMC
  1. S STA=$$STA^XUAF4(IEN) I STA="" G INSTSQ ;No Station Number
  1. I '$$ACTIVE^XUAF4(IEN) G INSTSQ ;Inactive
  1. S PRNT=$$PRNT^XUAF4(STA),PSTA=$P(PRNT,U,2)
  1. S OK=$S(PRNT="":0,PSTA="":1,PSTA=STA:1,1:0)
  1. INSTSQ ;Exit Screen
  1. Q OK
  1. ;
  1. PAYER(APP,ARRAY) ;Payer Lookup
  1. ;INPUT:
  1. ; APP - PAYER APPLICATION to include in lookup
  1. ; ARRAY - Results of lookup to be used by calling routine
  1. ;
  1. ;IB*737/TAZ - Removed references to "~NO PAYER" which was an input parameter
  1. ;
  1. N IBUTNI,PAYER,SCREEN
  1. I $G(APP)'="" S SCREEN="I $$PYRAPP^IBCNEUT5("""_APP_""",$G(Y))'="""""
  1. D LOOKUP(365.12,"Payer","PAYER",,,.SCREEN)
  1. M ARRAY=PAYER
  1. Q
  1. ;
  1. LOOKUP(FILE,IBPROMPT,ARRAY,IBALL,IBONE,SCREEN) ; Perform a lookup on the selected Dictionary
  1. ;variables:
  1. ; ARRAY - The array of results of selection. If not defined will return in
  1. ; * ^TMP($J,"IBCNINSL",<Uppercased IBPROMPT>)
  1. ; * Passed by reference
  1. ; You can use a local or global array but a local array may cause problems
  1. ; FILE - FILE number for lookup
  1. ; IBALL - Prompt for All
  1. ; IBPROMPT - Prompt for Dictionary
  1. ; IBONE - Return 1 selection
  1. ; SCREEN - Filter entries
  1. ; * This is set up in the calling subroutine and used. It must be Newed/Killed there.
  1. ;
  1. ;Get 1st Entry
  1. N DIC,DIR,IBI,QUIT,REMOVE,X,Y
  1. I '$D(ARRAY) S ARRAY=$NA(^TMP($J,"IBCNINSL",$$UP^XLFSTR(IBPROMPT)))
  1. K @ARRAY S (@ARRAY,IBI,QUIT,Y)=0 S IBUTNI=$G(IBUTNI,2)
  1. FIRST S DIR(0)="FAO",DIR("A")="Select "_IBPROMPT_": ",DIR("?")="^D QQ^IBCNINSL" S:$G(IBALL) DIR("B")="ALL"
  1. S DIC=FILE,DIC(0)="BEQZ" S:$G(SCREEN)]"" DIC("S")=SCREEN
  1. D ^DIR K DIR
  1. G ERR:(X="^")!'$T D:X["?" QQ,^DIC G:X="" QUIT I X="ALL",$G(IBALL) S @ARRAY=1 G QUIT
  1. S DIC=FILE,DIC(0)="BEQZ"
  1. I $G(SCREEN)'="" S DIC("S")=SCREEN
  1. S X=Y D ^DIC G:Y'>0 FIRST S IBI=1 D SET
  1. ;
  1. I $G(IBONE) G QUIT
  1. S IBALL=0
  1. ;
  1. ;Prompt for subsequent entries
  1. F IBI=IBI:1 D Q:QUIT
  1. . S REMOVE=0
  1. . S DIR(0)="FAO",DIR("A")="Select another "_IBPROMPT_": ",DIR("?")="^D QQ^IBCNINSL"
  1. . D ^DIR K DIR
  1. . I (X="^")!'$T!(X']"") S QUIT=1 Q
  1. . I X["?" D QQ
  1. . I $E(X)="-" S REMOVE=1,X=$E(X,2,$L(X))
  1. . S DIC=FILE,DIC(0)="BEQZ"
  1. . I $G(SCREEN)'="" S DIC("S")=SCREEN
  1. . D ^DIC I Y'>0 Q
  1. . D SET
  1. ;
  1. G QUIT
  1. ;
  1. SET ;Set into or remove from ARRAY
  1. N J
  1. I $G(REMOVE) D G SETQ
  1. . S J=$S(IBUTNI=2:+Y,1:$P(Y(0),"^"))
  1. . I '$D(@ARRAY@(J)) W *7,"...not on list...can't remove" Q
  1. . W *7,"...removed from list..."
  1. . K @ARRAY@(J)
  1. 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
  1. I IBUTNI=1 S @ARRAY@($P(Y(0),U))=+Y G SETQ
  1. I IBUTNI=3 S @ARRAY@($P(Y(0,0),U))=+Y G SETQ
  1. S @ARRAY@(+Y)=$P(Y(0),U)
  1. SETQ ;
  1. Q
  1. ;
  1. QQ ;Display Help
  1. N DIC,IBJ,IBJ1,PROMPT
  1. S PROMPT=IBPROMPT I "yY"[$E(PROMPT,$L(PROMPT)) S PROMPT=$E(PROMPT,1,$L(PROMPT)-1)_"ies"
  1. W !,"ENTER:"
  1. I $G(IBALL) W !?5,"- ALL (Default) for all ",PROMPT,", or"
  1. W !?5,"- Individual ",IBPROMPT
  1. W !?5,"- RETURN once all ",PROMPT," have been selected"
  1. I $O(@ARRAY@(0))]"" D
  1. . W !?5,"- An entry preceeded by a minus [-] sign to remove that entry from list."
  1. . W !!,"NOTE, you have already selected:"
  1. . S IBJ=0 F IBJ1=0:0 S IBJ=$O(@ARRAY@(IBJ)) Q:IBJ="" W !?8,$S(IBUTNI=1:IBJ,1:@ARRAY@(IBJ))
  1. W !
  1. S DIC=FILE,DIC(0)="BEQZ" S:$G(SCREEN)]"" DIC("S")=SCREEN D ^DIC
  1. Q
  1. ;
  1. ERR S Y=-1
  1. QUIT S:'$D(Y) Y=1
  1. Q
  1. ;