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

FBASF.m

Go to the documentation of this file. 
  1. FBASF ;AISC/JLG - ICD10 DIAGNOSIS CODE ASF (Advanced Search Functionality) ;3/26/2012
  1.  ;;3.5;FEE BASIS;**139**;JAN 30, 1995;Build 127
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ; Reference to API $$CODEN^ICDEX supported by ICR #5747
  1.  ;
  1.  ;Prompt for ICD10 diagnosis entries  
  1.  ; params, 1-Diagnosis prompt
  1.  ;         2-prompt line number (null if no number)
  1.  ;         3-allow up arrow (^) flag (optional) -if this is set to "Y" then the up arrow will be accepted for early exit
  1.  ;         4-allow deletion of DX field? (optional)  -if this is set to "Y", @ is an acceptable entry
  1.  ;         5-allow forcing a field to be required (optional)  -if this is set to "Y", the field will be forced to be required
  1. ASKICD10(DXPRMPT,LNNUM,ALWUPA,ALDEL,ALFREQ) ;
  1.  N FBOUT,FBDC,ICDRET,FBTMP,FBPRMPT  S FBDC=""
  1.  S FBPRMPT=DXPRMPT_LNNUM
  1.  S ICDRET=$$EN(EDATE,FBDC) ; EDATE must be assigned prior to calling this s/r. It represents 'date of interest'
  1.  D EXIT
  1.  Q ICDRET ;returns the value of ien or -1
  1.  ; 
  1. EN(EFFDATE,X) ; -- params 1-date of interest 2-diagnosis code
  1.  N FBQUIT,FBRETV,FBPARAM,FBCSYS,FBOUT,FBDFN
  1.  D SETPARAM(.FBPARAM) ; set screen messages
  1.  S FBDT=EFFDATE,FBFILE=DP,FBIEN=DA,FBDFLT="",FBRETV=0,FBOUT=""
  1.  S:$D(DFN) FBDFN=DFN
  1.  ; 161.01 is the sub-field authorization in fee basis patient file
  1.  S:FBFILE="161.01" FBDFLT=$$GETDC^FBASFU(FBFILE,FBDFN,FBIEN)
  1.  ; 162.7 is the unauthorized claim funds file
  1.  S:FBFILE="162.7" FBDFLT=$$GETDCUC^FBASFU(FBFILE,FBIEN)
  1.  S:FBDFLT']"" FBDFLT=$$GETVAL^FBASFU(FBFILE,FBIEN,FBPARAM("FIELD_NAME")) ; set default value if applicable
  1.  ;
  1. EN1 ; 
  1.  S FBRETV=$$DIAG10(FBDT,FBDFLT,.FBPARAM)
  1.  I (FBRETV']"")!(FBRETV<0) Q FBRETV
  1.  I FBRETV="@" Q FBRETV ; don't print labels for deletions
  1.  S FBRETV=$$PRTICD10^FBASFU(FBRETV) ; prints ICD code and description to the screen
  1.  S FBRETV=$P($P(FBRETV,"^"),";")
  1.  G:FBRETV=-1 EN1
  1.  Q FBRETV ; returns IEN file #80 or -1
  1.  ;//---------
  1.  ;The entry point for ICD-10 diagnosis search functionality
  1.  ;input parameters :
  1.  ; FBDT - date of interest
  1.  ; FBDFLT - default values for the search string (can be a code by default)
  1.  ; FBPARAM - parameters/string constants (see SETPARAM for details)
  1.  ;returns ICD-10 code selected by the user:
  1.  ;  IEN file #80;ICD code value^description
  1.  ; results
  1.  ; or -1 if invalid data(press enter)
  1.  ; "" if not found 
  1.  ; or -2 if time out
  1.  ; or -3 if ^ or ^^
  1.  ; or -4 in ICD10 if the usre answered NO for the question "Do you wish to continue(Y/N)?"
  1.  ; or -5 if deletion of DX field is attempted
  1.  ; 
  1. DIAG10(FBDT,FBDFLT,FBPARAM) ;
  1.  N FBINP,FBTMP,FBREQFLDMP
  1.  S:'$D(ALWUPA) ALWUPA="N" ; up arrow allow flag
  1.  S:'$D(ALDEL) ALDEL="N" ; delete allow flag
  1.  S:'$D(ALFREQ) ALFREQ="N" ; force required allow flag
  1. ASKAGAIN ;
  1.  S FBINP=$$SRCHSTR(FBPARAM("SEARCH_PROMPT"),FBPARAM("HELP ?"),FBPARAM("HELP ??"),FBDFLT)
  1.  ;user should enter at least 2 characters
  1.  I FBINP'<0 I $L($P(FBINP,U,2))'>1 W !!,FBPARAM("ENTER MORE") W:$L(FBPARAM("ENTER MORE2"))>0 !,FBPARAM("ENTER MORE2") W ! G ASKAGAIN
  1.  ; return values from SRCHSTR function ... $D(DTOUT) -2, $D(DUOUT) -3, Y["^" -3, Y="" -1, otherwise 0_U_Y
  1.  Q:FBINP=-2 FBINP ; timed out
  1.  Q:(ALWUPA="Y")&(FBINP=-3) FBINP ; "^" entered
  1.  S FBREQFLD=$$REQFLD^FBASFU(FBFILE,FBPARAM("FIELD_NAME"))
  1.  I ((ALFREQ="Y")&(FBINP=-5)) S FBREQFLD=0
  1.  I ((FBINP=-5)&('FBREQFLD)) W FBPARAM("REQUIRED") G ASKAGAIN
  1.  I ALDEL="Y",FBINP=-5,$G(FBDFLT)="" S ALDEL="N"
  1.  I ALDEL="Y",FBINP=-5 N FBYN D  Q:FBYN=1 "@" G ASKAGAIN
  1.  . S FBYN=$$QUESTION^FBASF(2,"SURE YOU WANT TO DELETE")
  1.  . I FBYN'=1 W FBPARAM("NOTHING DELETED")
  1.  I FBINP=-5 W "??" G ASKAGAIN
  1.  I ((FBREQFLD=-1)&(FBINP=-3)) W !,FBPARAM("EXIT NOT ALLOWED") G ASKAGAIN
  1.  Q:((FBREQFLD=-1)&(FBINP'[U)) FBINP ; if not a required field and NOT a valid search string for icd code
  1.  I FBINP=-1 D   ; if a space is entered for a required field
  1.  . W "??"
  1.  . I FBPARAM("SEARCH_PROMPT")["ADMITTING DIAGNOSIS" W !,FBPARAM("ENTER ADM DIAG")
  1.  I ((FBREQFLD=0)&(FBINP=-1)) G ASKAGAIN ;space entered for required field
  1.  I FBINP=-3 W !,FBPARAM("EXIT NOT ALLOWED") G ASKAGAIN ;^ entered for all ICD fields
  1.  S FBTMP=$$STATCHK^FBASFU($P(FBINP,U,2),FBDT) ; check if icd code is inactive
  1.  G:FBTMP=-1 ASKAGAIN ; If icd code is inactive
  1.  N FBMATCH S FBMATCH=$$ISMATCH($P(FBINP,U,2))
  1.  S FBINP=$$LEXICD10($P(FBINP,U,2),FBDT,.FBPARAM)
  1.  G:FBINP=-4 ASKAGAIN ; if the threshold for the results is reached and user wants to refine search criteria
  1.  I FBINP']"" W !,FBPARAM("NO MATCHES FOUND") I FBPARAM("SEARCH_PROMPT")["ADMITTING DIAGNOSIS" W !,"  ",FBPARAM("ENTER ADM DIAG")
  1.  G:FBINP']"" ASKAGAIN
  1.  G:FBINP=-1 ASKAGAIN
  1.  Q FBINP_"^"_FBMATCH
  1.  ;
  1.  ;input parameter - diagnosis code
  1.  ;Returns 0 (zero) if diagnosis code is an exact match, otherwise return -1
  1. ISMATCH(FBDCDE) ;
  1.  N FBMFLG S FBMFLG=-1 ;set default to -1
  1.  S:$$CODEN^ICDEX(FBDCDE,80)>0 FBMFLG=0
  1.  Q FBMFLG
  1.  ;--------------
  1.  ;The entry point for ICD-10 diagnosis search functionality
  1.  ;can be called from applications directly
  1.  ; Supported ICR 5681 ($$DIAGSRCH^LEX10CS)
  1.  ;input parameters :
  1.  ; FBTXT - search string
  1.  ; FBDATE - date of interest
  1.  ; FBPAR - array with text messages and other string constants
  1.  ;returns ICD-10 code selected by the user:
  1.  ;  IEN file #80;ICD code value^description
  1.  ; or 
  1.  ; "" if not found 
  1.  ; -1 if exit : ^ or ^^
  1.  ; -2 if continue searching
  1.  ;
  1. LEXICD10(FBTXT,FBDATE,FBPAR) ; ICD-10 Search
  1.  N FBLVTXT
  1.  ;parameters check
  1.  S FBDATE=+$G(FBDATE)
  1.  I FBDATE'?7N Q -1
  1.  S FBTXT=$G(FBTXT)
  1.  Q:'$L(FBTXT) -1
  1.  N FBNUMB
  1.  S FBNUMB=$$FREQ^LEXU(FBTXT)
  1.  I FBNUMB>$$MAX^LEXU(30) D  I $$QUESTION(2,FBPARAM("WISH CONTINUE"),FBPARAM("YES OR NO"))'=1 Q -4
  1.  . D FORMWRIT(FBPAR("EXCEEDS MESSAGE1")_FBTXT_FBPAR("EXCEEDS MESSAGE2")_FBNUMB_FBPAR("EXCEEDS MESSAGE3")_FBTXT_""".",0)
  1.  . D FORMWRIT("",2)
  1.  ;new and set variables
  1.  N DIROUT,DUOUT,DTOUT,FBEXIT,FBICDNT
  1.  N FBRETV,FBXX,FBLEVEL
  1.  S FBRETV=""
  1.  S FBEXIT=0
  1.  S FBLEVEL=1,FBLVTXT(FBLEVEL)=FBTXT ;level 1 stores the original search string
  1.  ; main loop
  1.  F  Q:FBEXIT>0  D
  1.  .K FBICDY
  1.  .;get the search string from the current level and call LEX API
  1.  .S FBICDY=$$DIAGSRCH^LEX10CS(FBLVTXT(FBLEVEL),.FBICDY,FBDATE,30)
  1.  .S:$O(FBICDY(" "),-1)>0 FBICDY=+FBICDY
  1.  .; Nothing found
  1.  .I +FBICDY'>0 S FBEXIT=1 S FBXX=-1 Q
  1.  .; Single match found for partial text search
  1.  .I FBMATCH<0,FBLEVEL=1,FBICDY=1 S FBMATCH=0
  1.  .; display the list of items and ask the user to select the item from the list
  1.  .S FBXX=$$SEL^FBASFL(.FBICDY,8)
  1.  .; if ^ was entered 
  1.  .;   if this is on the top level then quit 
  1.  .I FBXX=-2,FBLEVEL'>1 S FBRETV=-1 S FBEXIT=1 Q
  1.  .;   if lower level then go one level up
  1.  .I FBXX=-2,FBLEVEL>1 S:FBLEVEL>1 FBLEVEL=FBLEVEL-1 Q
  1.  .; If timeout, or not selected, or ^^ then quit
  1.  .I FBXX=-1 S FBRETV=-1 S FBEXIT=1 Q
  1.  .; if Code Found and Selected by the user save selection in FBRETV and quit
  1.  .I $P(FBXX,";")'="99:CAT" S FBRETV=FBXX S FBEXIT=1 Q
  1.  .; If Category Found and Selected by the user:  
  1.  .;  go to the next inner level
  1.  .;  change level number 
  1.  .S FBLEVEL=FBLEVEL+1
  1.  .;  set the new level with the new search string
  1.  .;  and repeat 
  1.  .S FBLVTXT(FBLEVEL)=$P($P($G(FBXX),"^"),";",2)
  1.  Q FBRETV
  1.  ;
  1.  ; Look-up help for ?
  1. INPHLP ;
  1.  I $G(X)["???" D INPHLP3 Q
  1.  I $G(X)["??" D INPHLP2 Q
  1.  W !," Enter code or ""text"" for more information." Q
  1.  Q
  1.  ;-----------
  1.  ; Look-up help for ??
  1. INPHLP2 ;
  1.  W !," Enter a ""free text"" term or part of a term such as ""femur fracture""."
  1.  W !!," or "
  1.  W !!," Enter a ""classification code"" (ICD/CPT etc) to find the single term"
  1.  W !," associated with the code."
  1.  W !!," or "
  1.  W !!," Enter a ""partial code"". Include the decimal when a search criterion"
  1.  W !," includes 3 characters or more for code searches."
  1.  Q
  1.  ;--------
  1.  ; Look-up help for ???
  1. INPHLP3 ;
  1.  W !," Number of Code Matches"
  1.  W !," ----------------------"
  1.  W !!," The ICD-10 Diagnosis Code search will show the user the number of matches"
  1.  W !," found, indicate if additional characters in ICD code exist, and the number"
  1.  W !," of codes within the category or subcategory that are available for selection."
  1.  W !," For example:"
  1.  W !!," 14 matches found"
  1.  W !!," M91. - Juvenile osteochondrosis of hip and pelvis (19)"
  1.  W !!," This indicates that 14 unique matches or matching groups have been found"
  1.  W !," and will be displayed."
  1.  W !!," M91. - the ""-"" indicates that there are additional characters that specify"
  1.  W !," unique ICD-10 codes available."
  1.  W !!," (19) Indicates that there are 19 additional ICD-10 codes in the M91 ""family"""
  1.  W !," that are possible selections."
  1.  Q
  1.  ;--------
  1.  ;ask YES/NO questions
  1.  ;input parameters :
  1.  ; FBDFLT- 0/null- not default, 1- yes, 2 -no
  1.  ; FBPROM - prompt string
  1.  ; FBHELP - help text
  1.  ;returns 
  1.  ; 2 - no,
  1.  ; 1 -yes,
  1.  ; 0 - no answer (time out)
  1.  ; -3 - ^ or ^^
  1.  ; 0 - no answer
  1. QUESTION(FBDFLT,FBPROM,FBHELP) ;
  1.  N DIR
  1.  S %=$G(FBDFLT,2)
  1.  S DIR(0)="Y",DIR("A")=FBPROM,DIR("B")=$S(%=1:"Yes",%=2:"No",1:"")
  1.  S:$L($G(FBHELP)) DIR("?")=FBHELP
  1.  D ^DIR
  1.  Q:Y["^" -3
  1.  Q:Y=1 1
  1.  Q:Y=0 2
  1.  Q 0
  1.  ;
  1.  ;------------
  1.  ;get search string
  1.  ;input parameters :
  1.  ; FBPRMT prompt text
  1.  ; FBHLP1 "?" help text
  1.  ; FBHLP2 "??" help text
  1.  ; FBDFLT- default response
  1.  ;returns piece1 ^ piece 2
  1.  ; piece1:
  1.  ; 0 if normal input
  1.  ; or -1 if invalid data
  1.  ; or -2 if time out
  1.  ; or -3 if ^
  1.  ; or -5 if @
  1.  ; piece2: string entered by the user
  1. SRCHSTR(FBPRMT,FBHLP1,FBHLP2,FBDFLT) ;
  1.  N DIR
  1.  S DIR("A")=FBPRMT
  1.  S DIR("?")=FBHLP1
  1.  S DIR("??")=FBHLP2
  1.  I $L($G(FBDFLT)) S DIR("B")=FBDFLT
  1.  S DIR(0)="FAOr^0:245"
  1.  D ^DIR
  1.  Q:$D(DTOUT) -2
  1.  Q:$D(DUOUT) -3
  1.  Q:X="@" -5
  1.  Q:Y["^" -3
  1.  Q:Y="" -1
  1.  Q 0_U_Y
  1.  ;
  1.  ;set parameters
  1.  ;input parameters 
  1.  ; FBPAR - local array to sets and store string constants for your messages and prompts 
  1. SETPARAM(FBPAR) ;
  1.  S FBPAR("ASKDATE")="Date of interest? "
  1.  I FBPRMPT'[":" S FBPRMPT=FBPRMPT_": "
  1.  S FBPAR("SEARCH_PROMPT")=FBPRMPT
  1.  S FBPAR("HELP ?")="^D INPHLP^FBASF"
  1.  S FBPAR("HELP ??")="^D INPHLP2^FBASF"
  1.  S FBPAR("NO DATA FOUND")="  No data found"
  1.  S FBPAR("EXITING")="  Exiting"
  1.  S FBPAR("TRY LATER")="  Try again later"
  1.  S FBPAR("NO DATA SELECTED")="  No data selected"
  1.  S FBPAR("TRY ANOTHER")="Try another"
  1.  S FBPAR("WISH CONTINUE")="Do you wish to continue(Y/N)"
  1.  S FBPAR("EXCEEDS MESSAGE1")="Searching for """
  1.  S FBPAR("EXCEEDS MESSAGE2")=""" requires inspecting "
  1.  S FBPAR("EXCEEDS MESSAGE3")=" records to determine if they match the search criteria.  This could take quite some time.  Suggest refining the search by further specifying """
  1.  S FBPAR("NO MATCHES FOUND")="  No matches found??"
  1.  S FBPAR("ENTER ADM DIAG")="  Enter the admitting diagnosis for this claim."
  1.  S FBPAR("EXIT NOT ALLOWED")="   Exit not allowed??"
  1.  S FBPAR("ENTER MORE")=" Please enter at least the first two characters of the ICD-10 code or code"
  1.  S FBPAR("ENTER MORE2")=" description to start the search."
  1.  S FBPAR("YES OR NO")="Answer 'Y' for 'Yes' or 'N' for 'No'"
  1.  S FBPAR("NOTHING DELETED")="  <NOTHING DELETED>"
  1.  S FBPAR("REQUIRED")="??  Required"
  1.  N FBX S FBX=FBPRMPT
  1.  F  Q:(($E(FBX)'=" ")&($E(FBX)'?1C))  S FBX=$E(FBX,2,99) ; remove leading space or control chars.
  1.  S FBPAR("FIELD_NAME")=$P(FBX,":")
  1.  Q
  1.  ;
  1.  ;
  1.  ;a wrapper for ^DIWP
  1.  ;accumulates a text and then writes it to the device
  1.  ;input parameters :
  1.  ; X - text
  1.  ; FBMODE:
  1.  ;  0 - start
  1.  ;  1 - accumulate 
  1.  ;  2 - write
  1.  ;example:
  1.  ;D FORMWRIT^FBASF("this API is a wrapper for ^DIWP, it accumulates a text and then writes it to the device, you can use it in your application code",0)
  1.  ;D FORMWRIT^FBASF("some more text ",1)
  1.  ;D FORMWRIT^FBASF("",2)
  1. FORMWRIT(X,FBMODE) ;
  1.  N FBLI1
  1.  ;if "start" mode
  1.  I FBMODE=0 K ^UTILITY($J,"W")
  1.  S DIWL=1,DIWR=79
  1.  I $L(X)>0 D ^DIWP
  1.  ;if "write" mode
  1.  I FBMODE=2 D
  1.  . S FBLI1=0 F  S FBLI1=$O(^UTILITY($J,"W",1,FBLI1)) Q:+FBLI1=0  W !,$G(^UTILITY($J,"W",1,FBLI1,0))
  1.  . K ^UTILITY($J,"W")
  1.  Q
  1.  ;
  1.  ; Clean up environment and quit
  1. EXIT ;
  1.  K %,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,%Y,FBDT,FBFILE,FBIEN,FBDFLT,FBOUT,FBREQFLD,DXPRMPT,LNNUM,DIWL,DIWR
  1.  Q
  1.  ;