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

BLRSNOMU.m

Go to the documentation of this file. 
  1. BLRSNOMU ; IHS/OIT/MKK - IHS Lab SNOMED Utilities ; 17-Oct-2014 09:22 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1033,1034**;NOV 1, 1997;Build 88
  1.  ;
  1.  ; Requires user to enter free text input so as to retrieve matches from the
  1.  ; BSTS terminology server.
  1.  ;
  1. PEP ; EP
  1. EP ; EP
  1. EEP ; Ersatz EP
  1.  D EEP^BLRGMENU
  1.  Q
  1.  ;
  1.  ; Requried variables are:
  1.  ;     (1) DFN    -- Patient Pointer to file 2
  1.  ;     (2) LRORD  -- Order Number
  1.  ;     (3) LRODT  -- Order Date
  1.  ;
  1. GETSDIAG(LRORD,LRODT,TESTIEN) ; EP - Get & Store Diagnosis
  1.  NEW (DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRORD,LRODT,PNM,HRCN,TESTIEN,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S LRDFN=+$G(^DPT(DFN,"LR"))
  1.  ;
  1.  S PROBSTR=$$TEXTPOVI(DFN)
  1.  ;
  1.  I $L(PROBSTR)<1 D FATALERR  Q
  1.  ;
  1.  D STORDIAG
  1.  Q
  1.  ;
  1. TEXTPOVI(DFN) ; EP - Use Text & BSTS Database
  1.  NEW (DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,HRCN,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,PNM,U,XPARSYS,XQXFLG)
  1.  ;
  1.  ; User MUST enter a diagnosis.  No exceptions.
  1.  S Y=0
  1.  F  Q:Y  D
  1.  . W !!
  1.  . D ^XBFMK
  1.  . S DIR(0)="F"
  1.  . S DIR("A")="Enter Clinical Indication (Free Text)"
  1.  . D ^DIR
  1.  . I $G(X)="^^^"  S Y=99999999  Q      ; Trick to exit
  1.  . ;
  1.  . I $L(X)<1!(+$G(DIRUT)) D  Q
  1.  .. W !!,?4,"Invalid.  Must Enter a Clinical Indication.",!
  1.  .. D PRESSKEY^BLRGMENU(9)
  1.  .. S Y=0
  1.  . K VARS,IN
  1.  . S OUT="VARS",IN=$G(X)_"^F^^^^300"
  1.  . S Y=$$SEARCH^BSTSAPI(OUT,IN)
  1.  . I Y<1 W !!,?9,"No entries found in the IHS STANDARD TERMINOLOGY database.  Try Again."
  1.  ;
  1.  D:$G(X)="^^^" FATALERR
  1.  ;
  1.  S (NUM,CNT)=0
  1.  K ^TMP("BLRSNO"),BLRSNOX
  1.  ; Call List Manager routine
  1.  D EN^BLRSNO
  1.  ;
  1.  ;
  1.  F  S NUM=$O(VARS(NUM))  Q:NUM<1  D
  1.  . Q:$L($G(VARS(NUM,"ICD",1,"COD")))<1&($L($G(VARS(NUM,"10D",1,"COD")))<1)
  1.  . ;
  1.  . S CNT=CNT+1
  1.  . ; Setup List Manager Array
  1.  . D SET^VALM10(CNT,$J(CNT,3)_"  "_$$LJ^XLFSTR($G(VARS(NUM,"FSN","DSC")),14)_$G(VARS(NUM,"FSN","TRM")))
  1.  . S BLRSNOX(CNT,NUM)=""            ; Build "Cross Reference" Array
  1.  ;
  1.  S VALMCNT=CNT
  1.  S MAXSEARCH=$O(VARS("A"),-1)
  1.  ;
  1.  S WHATSEL=0
  1.  F  Q:+WHATSEL!(BOOM)  D
  1.  . D MAKEDIR(WHATSEL)
  1.  . M TMPDIR=DIR
  1.  . ;
  1.  K ICDCODES
  1.  S (CNT,NUM)=0
  1.  F  S NUM=$O(VARS(NUM))  Q:NUM<1!(CNT>17)  D
  1.  . Q:$L($G(VARS(NUM,"ICD",1,"COD")))<1&($L($G(VARS(NUM,"10D",1,"COD")))<1)
  1.  . ;
  1.  . Q:$L($G(ICDCODES($G(VARS(NUM,"ICD",1,"COD")))))
  1.  . S ICDCODES($G(VARS(NUM,"ICD",1,"COD")))=$G(VARS(NUM,"FSN","TRM"))_"^^"_$G(VARS(NUM,"FSN","DSC"))
  1.  . S CNT=CNT+1
  1.  ;
  1.  S DIRZERO="S^"
  1.  S (CNT,ICDCODE)=0
  1.  F  S ICDCODE=$O(ICDCODES(ICDCODE))  Q:ICDCODE<1  D
  1.  . S ICDDESC=$P($G(ICDCODES(ICDCODE)),"^")
  1.  . S SNOMED=$P($G(ICDCODES(ICDCODE)),"^",3)
  1.  . S CNT=CNT+1
  1.  . S DIRZERO=DIRZERO_CNT_":"_ICDCODE_";"
  1.  . S STR=$J(CNT,4)_") "
  1.  . S $E(STR,7)=ICDCODE
  1.  . S:$G(DEBUG)'="YES" $E(STR,20)=$E(ICDDESC,1,53)
  1.  . S:$G(DEBUG)="YES" $E(STR,20)=$E(ICDDESC,1,38),$E(STR,60)=$S(SORTDATE:$$FMTE^XLFDT(SORTDATE,"5DZ"),1:" ")
  1.  . S DIRZERO(CNT)=$$LJ^XLFSTR(STR,75)
  1.  . S ICDINDEX(CNT)=ICDCODE_"^"_ICDDESC_"^^"_SNOMED
  1.  ;
  1.  D MAKEDIR           ; Create DIR array
  1.  ;
  1.  M TMPDIR=DIR        ; Allows DIR array to be reset in the following FOR loop
  1.  ;
  1.  ; User MUST select an entry.  No exceptions.
  1.  S Y=0
  1.  F  Q:Y  D
  1.  . W !!
  1.  . D ^DIR
  1.  . I +$G(Y)<1!(+$G(DIRUT)) D
  1.  .. W !!,?4,"Invalid.  Must Select an Entry.",!
  1.  .. D PRESSKEY^BLRGMENU(9)
  1.  .. D ^XBFMK
  1.  .. S Y=0
  1.  .. M DIR=TMPDIR
  1.  ;
  1.  Q $G(ICDINDEX(Y))
  1.  ;
  1. STORDIAG ; EP - Store the Same ICD code on ALL tests in an order
  1.  NEW DESCIEN,ERRS,FDA,ICDIEN,ICDSTR,ICDCODE,ICDDESC,ICDSTR,IENS,LATEST,LRSN,LRTST
  1.  ;
  1.  S ICDCODE=$P(PROBSTR,"^")
  1.  S ICDDESC=$P(PROBSTR,"^",2)
  1.  S PROVNARR=$P(PROBSTR,"^",3)                    ; Provider Narrative, if it exists
  1.  S:$L(PROVNARR)<1 PROVNARR=ICDDESC               ; If it doesn't exist, set to ICD Description
  1.  S SNOMED=$P(PROBSTR,"^",4)
  1.  ;
  1.  S LRSN=.9999999
  1.  F  S LRSN=$O(^LRO(69,"C",LRORD,LRODT,LRSN)) Q:LRSN<1  D
  1.  . S LRTST=.9999999
  1.  . F  S LRTST=$O(^LRO(69,LRODT,1,LRSN,2,LRTST))  Q:LRTST<1  D
  1.  .. D ^XBFMK
  1.  .. K FDA,ERRS,IENS
  1.  .. S IENS=LRTST_","_LRSN_","_LRODT_","
  1.  .. S FDA(69.03,IENS,9999999.1)=$S($L(PROVNARR):PROVNARR,$L(ICDDESC):ICDDESC,1:" ")
  1.  .. S:$L(SNOMED) FDA(69.03,IENS,9999999.2)=SNOMED
  1.  .. D FILE^DIE("EKS","FDA","ERRS")
  1.  .. I $D(ERRS) D ERRMSG("STORDIAG^BLRSNOMU FILE^DIE")
  1.  .. Q:$L(ICDCODE)<1
  1.  .. ;
  1.  .. K FDA,ERRS
  1.  .. S FDA(69.05,"?+1,"_IENS,.01)=ICDCODE
  1.  .. D UPDATE^DIE("ES","FDA",,"ERRS")
  1.  .. I $D(ERRS) D ERRMSG("STORDIAG^BLRSNOMU UPDATE^DIE")
  1.  Q
  1.  ;
  1. MAKEDIR ; EP - Create DIR array for ICD Codes
  1.  D ^XBFMK
  1.  S DIR(0)=DIRZERO
  1.  S DIR("L",1)="Select Clinical Indication for "_PNM_" ["_HRCN_"]:"
  1.  S DIR("L",2)=" "
  1.  S DIR("L",3)="     SNOMED         SNOMED Description"
  1.  ;             12345678901234567890123456789012345678901234567890123456789012345678901234567890
  1.  S DIR("L",4)="     ----------- ---------------------------------------------------------------"
  1.  S BELOW=5
  1.  S CNT=0
  1.  F  S CNT=$O(DIRZERO(CNT))  Q:CNT<1  D
  1.  . ; S DIR("L",BELOW)=$J("",2)_$G(DIR("L",BELOW))_DIRZERO(CNT)
  1.  . S DIR("L",BELOW)=$G(DIR("L",BELOW))_DIRZERO(CNT)
  1.  . S BELOW=BELOW+1
  1.  ;
  1.  S DIR("L")=""
  1.  S DIR("A")="Selection"
  1.  Q
  1.  ;
  1. FATALERR ; EP - Hard Crash the process
  1.  NEW ROWSTARS,SPACER,SPACERLN,STR,STRLEN
  1.  ;
  1.  S STR="@NO@SIGN@NOR@SYMPTOM!@FORCE@CRASH!@"
  1.  S STRLEN=$L(STR)
  1.  S SPACER=$TR($J("",STRLEN)," ","@")
  1.  S ROWSTARS=$TR($J("",IOM)," ","*")
  1.  S SPACERLN=$TR($$CJ^XLFSTR(SPACER,IOM),"@ "," *")
  1.  ;
  1.  D ^XBCLS
  1.  W ROWSTARS,!
  1.  W ROWSTARS,!
  1.  W SPACERLN,!
  1.  W $TR($$CJ^XLFSTR(STR,IOM),"@ "," *")
  1.  W SPACERLN,!
  1.  W ROWSTARS,!
  1.  W ROWSTARS,!
  1.  ;
  1.  W !!,"Occurring in "  F X=5:-1:1 W X,"..."  H 1
  1.  ;
  1.  D ^LRKILL
  1.  ;
  1.  D BIGWORD("BOOM")
  1.  W 1/0
  1.  Q
  1.  ;
  1. BIGWORD(LRLTR) ; EP
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRLTR,U,XPARSYS,XQXFLG)
  1.  ;
  1.  I '$D(^TMP("LRLTR",$J,"A")) D ^LRLTR2
  1.  ;
  1. B1 ; EP
  1.  S LRLTY=$E(LRLTR,1,6),LRLTX=""
  1.  F LRLT1=1:1:$L(LRLTY) I $A(LRLTY,LRLT1)>32,$D(^TMP("LRLTR",$J,$E(LRLTY,LRLT1))) S LRLTX=LRLTX_$E(LRLTY,LRLT1)
  1.  D B2
  1.  K LRLT1,LRLT2,LRLT3,LRLTX,LRLTY,LRLT,LRJ0,LRJ02 W !
  1.  Q
  1.  ;
  1. B2 ; EP
  1.  W !
  1.  F LRLT1=9:-1:1 W ! F LRLT3=1:1:$L(LRLTX) S X=^TMP("LRLTR",$J,$E(LRLTX,LRLT3)) W "   " F LRLT2=1:1:5 W $S($E(X,(LRLT2-1*9+LRLT1)):"XXX",1:"   ")
  1.  Q
  1.  ;
  1. ERRMSG(MSG) ; EP - Error occurred during a DIE call
  1.  NEW LRCNT,LRMTXT,MESSAGE,NOWDTIME,TAB,WOTARR1,WOTARR2,WOTVAR
  1.  ;
  1.  S TAB=$J("",10)
  1.  ;
  1.  S MESSAGE="FileMan DBS call failed."
  1.  ;
  1.  S LRMTXT(1)=MSG_" Issue"
  1.  S LRMTXT(2)=" "
  1.  S LRMTXT(3)="The following debugging information is provided to assist"
  1.  S LRMTXT(4)="support staff in resolving the error."
  1.  ;
  1.  S LRMTXT(5)=" "
  1.  S LRCNT=5
  1.  ;
  1.  S LRCNT=LRCNT+1,LRMTXT(LRCNT)="     DUZ="_$G(DUZ)
  1.  S LRCNT=LRCNT+1,LRMTXT(LRCNT)="     DUZ(2)="_$G(DUZ(2))
  1.  S LRCNT=LRCNT+1,LRMTXT(LRCNT)=" "
  1.  ;
  1.  ; Store Arrays
  1.  F WOTARR1="ERRS","FDA","FDAIEN","LR68","LRAA","LRAD","LRAN","LRDFN","LRDIE","LRSS","LRTSTS","LRUNQ","LRWLC","XQY","XQY0" D
  1.  . S X=$G(@WOTARR1)
  1.  . I X'="" S LRCNT=LRCNT+1,LRMTXT(LRCNT)=WOTARR1_"="_X
  1.  . S WOTARR2=WOTARR1
  1.  . F  S WOTARR2=$Q(@WOTARR2) Q:WOTARR2=""  S LRCNT=LRCNT+1,LRMTXT(LRCNT)=WOTARR2_"="_@WOTARR2
  1.  ;
  1.  ; Store variables
  1.  F WOTVAR="DFN","LRORD","LRODT","LRSP","PROBSTR","SNOMED","DESCPROB","ICDCODE","ICDDESC" D
  1.  . S LRCNT=LRCNT+1,LRMTXT(LRCNT)=TAB_WOTVAR_"="_$G(@WOTVAR)
  1.  ;
  1.  ; D MAILALMI^BLRUTIL3(.MESSAGE,.LRMTXT,"BLRSNOMU",1)
  1.  ;
  1.  ; Store errors for 30 days
  1.  S NOWDTIME=$$HTFM^XLFDT($H)
  1.  I +$P($G(^XTMP("BLRSNOMU",0)),"^")'>(+NOWDTIME) D
  1.  . K ^XTMP("BLRSNOMU")
  1.  . S ^XTMP("BLRSNOMU",0)=$$HTFM^XLFDT(+$H+30)_"^"_$$DT^XLFDT_"^Temporary Error Message Storage for BLRSNOMU routine"
  1.  ;
  1.  M ^XTMP("BLRSNOMU",NOWDTIME,MSG)=LRMTXT
  1.  Q