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

BLRSGNS2.m

Go to the documentation of this file. 
  1. BLRSGNS2 ; IHS/OIT/MKK - IHS Lab SiGN or Symptom debug, part 2 ; 31-Jul-2015 06:30 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1033,1034,1035**;NOV 1, 1997;Build 5
  1.  ;
  1.  ; Some routines moved here from BLRSGNSD because BLRGSNSD became too large.
  1.  ;
  1. EEP ; Ersatz EP
  1.  D EEP^BLRGMENU
  1.  Q
  1.  ;
  1. NEWPROBS ; EP - Latest entries in the Problem file
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:$$NEWPROBI()="Q"
  1.  ;
  1.  F  S ENTDT=$O(^TMP("BLRSGNSD",$J,ENTDT),-1)  Q:ENTDT<1!(QFLG="Q")  D
  1.  . S IEN=0
  1.  . F  S IEN=$O(^TMP("BLRSGNSD",$J,ENTDT,IEN))  Q:IEN<1!(QFLG="Q")  D NPRBLINE
  1.  ;
  1.  W !!,?4,CNT," Entries with ICD Codes."
  1.  D PRESSKEY^BLRGMENU(9)
  1.  K ^TMP("BLRSGNSD")
  1.  Q
  1.  ;
  1. NEWPROBI() ; EP - Initialization
  1.  D SETBLRVS("NEWPROBS")
  1.  K ^TMP("BLRSGNSD")
  1.  ;
  1.  S HEADER(1)="Latest Modified Entries"
  1.  S HEADER(2)="PROBLEM (#9000011) File"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  W ?4,"Compiling"
  1.  S IEN=.9999999,(CNT,PROBCNT)=0
  1.  F  S IEN=$O(^AUPNPROB(IEN))  Q:IEN<1  D
  1.  . S CNT=CNT+1
  1.  . W:(CNT#1000)=0 "."  W:$X>75 !,?4
  1.  . ;
  1.  . Q:$D(^AUPNPROB(IEN,800))<1   ; Skip if no SNOMED entries
  1.  . ;
  1.  . ; S PROBICD=$$ICDDX^ICDCODE(+$G(^AUPNPROB(IEN,0)))
  1.  . S PROBICD=$$ICDDX^ICDEX(+$G(^AUPNPROB(IEN,0)))     ; IHS/MSC/MKK - LR*5.2*1034
  1.  . Q:PROBICD<1
  1.  . ;
  1.  . S PROBCNT=PROBCNT+1
  1.  . ;
  1.  . S ^TMP("BLRSGNSD",$J,+$P($G(^AUPNPROB(IEN,0)),"^",8),IEN)=""
  1.  ;
  1.  W !!,?4,$FN(CNT,",")," Entries in the Problem File (#9000011) Analyzed."
  1.  W !!,?9,$S(PROBCNT:$FN(PROBCNT,","),1:"No")," Entries with ICD Codes."
  1.  W:PROBCNT<1 " Routine Ends."
  1.  D PRESSKEY^BLRGMENU(14)
  1.  Q:PROBCNT<1 "Q"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  D HEADONE^BLRGMENU(.HDRONE)
  1.  ;
  1.  S MAXLINES=IOSL-4,LINES=MAXLINES+10
  1.  S QFLG="NO"
  1.  S (CNT,PG)=0
  1.  ;
  1.  S HEADER(3)=" "
  1.  S HEADER(4)="Entry",$E(HEADER(4),11)="Prob",$E(HEADER(4),59)="SNOMED CT",$E(HEADER(4),70)="SNOMED CT"
  1.  S HEADER(5)="Date",$E(HEADER(5),11)="IEN",$E(HEADER(5),20)="STS"
  1.  S $E(HEADER(5),25)="ICD CODE",$E(HEADER(5),35)="ICD DESCRIPTION"
  1.  S $E(HEADER(5),59)="CONCEPT",$E(HEADER(5),70)="DESIGNATION"
  1.  ;
  1.  S ENTDT="A"
  1.  Q "OK"
  1.  ;
  1. NPRBLINE ; EP - Line of Data
  1.  D BREAKOUT^BLRSGNSD    ; Breakout Variables.  Skip if there is an issue.
  1.  ;
  1.  I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)  Q:QFLG="Q"
  1.  ;
  1.  W $$FMTE^XLFDT(ENTDT,"2DZ")
  1.  W ?10,IEN
  1.  W ?20,STATUS
  1.  W ?24,ICDCODE,?34,$E(ICDDESC,1,22)
  1.  W ?58,$$GET1^DIQ(9000011,IEN,80001)
  1.  W ?69,$$GET1^DIQ(9000011,IEN,80002)
  1.  W !
  1.  ;
  1.  S LINES=LINES+1
  1.  S CNT=CNT+1
  1.  Q
  1.  ;
  1. CHKPLIST(DFN) ; EP - Check Problem List.
  1.  NEW PROBICD,PROBCNT,PROBIEN
  1.  ;
  1.  S PROBCNT=0,PROBICD="",PROBIEN="AAA"
  1.  F  S PROBIEN=$O(^AUPNPROB("AC",DFN,PROBIEN),-1)  Q:PROBIEN<1  D
  1.  . Q:$D(^AUPNPROB(PROBIEN,800))<1   ; Skip if no SNOMED entries
  1.  . ;
  1.  . ; S PROBICD=$$ICDDX^ICDCODE(+$G(^AUPNPROB(PROBIEN,0)))
  1.  . S PROBICD=$$ICDDX^ICDEX(+$G(^AUPNPROB(PROBIEN,0)))      ; IHS/MSC/MKK - LR*5.2*1034
  1.  . S PROBCNT=PROBCNT+1
  1.  ;
  1.  Q:PROBCNT>1 0            ; More than one entry in the PROBLEM list.
  1.  ;
  1.  Q:PROBCNT<1 1            ; No Problems in list
  1.  ;
  1.  ; If only one Problem and it's 799.9, treat it as if no problem in the PROBLEM list.
  1.  Q $S($P(PROBICD,"^",2)=799.9:1,1:0)
  1.  ;
  1. RESETOFD ; EP - Given an Order Number, reset the Provider Narrative, SNOMED, & ICD fields, if possible, in file 69
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D SETBLRVS
  1.  ;
  1.  S HEADER(1)="Reset Order File"
  1.  S HEADER(2)="Sign/Symptom Variables Only"
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  D ^XBFMK
  1.  S DIR(0)="NO"
  1.  S DIR("A")="Order Number"
  1.  S DIR("T")=1800   ; IHS/MSC/MKK - LR*5.2*1035 - Wait 30 Minutes
  1.  D ^DIR
  1.  I +$G(Y)<1!(+$G(DIRUT)) D  Q
  1.  . W !!,?4,"No/Invalid Entry.  Routine Ends."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  S ORDNUM=+$G(Y)
  1.  S LRODT=$O(^LRO(69,"C",ORDNUM,0)),LRSP=$O(^LRO(69,"C",ORDNUM,LRODT,0))
  1.  S LRDFN=+$G(^LRO(69,LRODT,1,LRSP,0)),DFN=+$P($G(^LR(LRDFN,0)),"^",3)
  1.  ;
  1.  D ALLTESTS^BLRSGNSY(DFN,ORDNUM,LRODT)
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  S TEST=0
  1.  F  S TEST=$O(^LRO(69,LRODT,1,LRSP,2,TEST))  Q:TEST<1  D
  1.  . S IENS=TEST_","_LRSP_","_LRODT_","
  1.  . W ?9,"PROVIDER NARRATIVE:",$$GET1^DIQ(69.03,IENS,"PROVIDER NARRATIVE"),!
  1.  . W ?21,"SNOMED:",$$GET1^DIQ(69.03,IENS,"SNOMED"),!
  1.  . D ICDCODE^BLRSGNSD
  1.  Q
  1.  ;
  1. JUSTVALS ; EP - Given input, just display ALL entries returned from BSTS server.
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  ;
  1.  D:+$G(IOM)<1 HOME^%ZIS
  1.  ;
  1.  D ^XBFMK
  1.  S DIR(0)="FO"
  1.  S DIR("A")="Search Text"
  1.  S DIR("T")=1800   ; IHS/MSC/MKK - LR*5.2*1035 - Wait 30 Minutes
  1.  D ^DIR
  1.  I $L(X)<1 D  Q
  1.  . W !,?4,"No/Invalid Entry.  Routine Ends."
  1.  . D PRESSKEY^BLRGMENU
  1.  ;
  1.  ; S OUT="VARS",IN=$G(X)_"^F^^^^500",$P(IN,"^",5)=$$DT^XLFDT
  1.  S OUT="VARS",IN=$G(X)_"^S^^^^500",$P(IN,"^",5)=$$DT^XLFDT      ; IHS/MSC/MKK - LR*5.2*1034
  1.  S Y=+$$SEARCH^BSTSAPI(OUT,IN)
  1.  D ADDICD9^BLRSGNSU
  1.  I Y<1 D  Q
  1.  . W !,?4,"No data returned for ",X," input.  Routine ends."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  S HEADER(1)="RPMS Lab Meaningful Use Stage 2"
  1.  ; S HEADER(2)="Sign or Symptom Debug Routines"
  1.  S HEADER(2)="Clinical Indication Debug Routines"
  1.  S HEADER(3)=$$CJ^XLFSTR("Terminology Server Response",IOM)
  1.  S HEADER(4)=$$CJ^XLFSTR("Search Text:"_$G(X),IOM)
  1.  S HEADER(5)=" "
  1.  ; S HEADER(6)="WOT",$E(HEADER(6),10)="ICD"
  1.  ; S $E(HEADER(6),20)="FSN/DSC",$E(HEADER(6),35)="FSN/TRM"
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
  1.  S HEADER(6)="WOT",$E(HEADER(6),10)="ICD-10"     ; 
  1.  S $E(HEADER(6),20)="FSN/DSC",$E(HEADER(6),35)="FSN/TRM"
  1.  S $E(HEADER(6),70)="ICD-9"  ; IHS/MSC/MKK - LR*5.2*1034
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1034
  1.  ;
  1.  S MAXLINES=20,LINES=MAXLINES+10,(CNT,PG)=0,QFLG="NO"
  1.  ;
  1.  S (CNT,WOT)=0
  1.  F  S WOT=$O(VARS(WOT))  Q:WOT<1!(QFLG="Q")  D
  1.  . I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,.HDRONE)  Q:QFLG="Q"
  1.  . ;
  1.  . W WOT
  1.  . W ?9,$G(VARS(WOT,"ICD",1,"COD"))
  1.  . W ?19,$G(VARS(WOT,"FSN","DSC"))
  1.  . ; W ?34,$E($G(VARS(WOT,"FSN","TRM")),1,46)
  1.  . W ?34,$E($G(VARS(WOT,"FSN","TRM")),1,33)      ; IHS/MSC/MKK - LR*5.2*1034
  1.  . W ?69,$G(VARS(WOT,"IC9",1,"COD"))             ; IHS/MSC/MKK - LR*5.2*1034
  1.  . W !
  1.  . S LINES=LINES+1
  1.  . S SYN=0
  1.  . F  S SYN=$O(VARS(WOT,"SYN",SYN))  Q:SYN<1!(QFLG="Q")  D
  1.  .. I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,.HDRONE)  Q:QFLG="Q"
  1.  .. W ?9," SYNONYM"
  1.  .. W ?19,$G(VARS(WOT,"SYN",SYN,"DSC"))
  1.  .. W ?34,$E($G(VARS(WOT,"SYN",SYN,"TRM")),1,46)
  1.  .. W !
  1.  .. S LINES=LINES+1
  1.  . S CNT=CNT+1
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. JUSTICDS ; EP - Given input, just display ALL entries returned from BSTS server that have ICD Code
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:$$JUSTICDI()="Q"
  1.  ;
  1.  F  S WOT=$O(VARS(WOT))  Q:WOT<1!(QFLG="Q")  D
  1.  . ; Q:$G(VARS(WOT,"ICD",1,"COD"))=""
  1.  . S BSTSCNT=BSTSCNT+1
  1.  . S ICDCODE=$G(VARS(WOT,"ICD",1,"COD"))
  1.  . Q:ICDCODE=""
  1.  . ;
  1.  . I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)  Q:QFLG="Q"
  1.  . ;
  1.  . W WOT
  1.  . W ?9,$G(VARS(WOT,"ICD",1,"COD"))
  1.  . W ?17,$G(VARS(WOT,"FSN","DSC"))
  1.  . D LINEWRAP^BLRGMENU(29,$G(VARS(WOT,"FSN","TRM")),51)
  1.  . W !
  1.  . S LINES=LINES+1
  1.  . S CNT=CNT+1
  1.  ;
  1.  W !!,?4,BSTSCNT," BSTS Entries."
  1.  W:CNT !!,?9,CNT," Valid ICD Code Entries."
  1.  ;
  1.  D PRESSKEY^BLRGMENU($S(CNT:14,1:9))
  1.  Q
  1.  ;
  1. JUSTICDI() ; EP - Initialization
  1.  S BLRVERN=$TR($P($T(+1),";")," "),BLRVERN2="JUSTICDS"
  1.  ;
  1.  S HEADER(1)="RPMS Lab Meaningful Use Stage 2"
  1.  S HEADER(2)="Clinical Indication Debug Routines"
  1.  S HEADER(3)=$$CJ^XLFSTR("Terminology Server Response with ICDs",IOM)
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  D HEADONE^BLRGMENU(.HDRONE)
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  D ^XBFMK
  1.  S DIR(0)="FO"
  1.  S DIR("A")="Search Text"
  1.  S DIR("T")=1800   ; IHS/MSC/MKK - LR*5.2*1035 - Wait 30 Minutes
  1.  D ^DIR
  1.  Q:$L(X)<1!(+$G(DIRUT)) $$BADENDQ("No/Invalid Entry.  Routine Ends.")
  1.  D PRESSKEY^BLRGMENU
  1.  ;
  1.  S OUT="VARS",IN=$G(X)_"^F^^^^500",$P(IN,"^",5)=$$DT^XLFDT
  1.  ;
  1.  Q:+$$SEARCH^BSTSAPI(OUT,IN)<1 $$BADENDQ("No data returned for "_X_" input.")
  1.  ;
  1.  D ADDICD9^BLRSGNSU
  1.  ;
  1.  S HEADER(4)=$$CJ^XLFSTR("Search Text:"_$G(X),IOM)
  1.  S HEADER(5)=" "
  1.  S HEADER(6)="WOT",$E(HEADER(6),10)="ICD"
  1.  S $E(HEADER(6),18)="SNOMED",$E(HEADER(6),30)="DESCRIPTION"
  1.  ;
  1.  S MAXLINES=20,LINES=MAXLINES+10,(CNT,PG)=0,QFLG="NO"
  1.  ;
  1.  S (CNT,WOT)=0
  1.  S BSTSCNT=0
  1.  Q "OK"
  1.  ;
  1. ERRMSGRP ; EP - Report on Error Messages stored in the ^XTMP global by ERRMSG^BLRSGNS3
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D SETBLRVS("ERRMSGRP")
  1.  ;
  1.  S HEADER(1)="IHS Laboratory"
  1.  S HEADER(2)="Error Messages Generated by BLRSGNSP"
  1.  S HEADER(3)=" "
  1.  S HEADER(4)="Order #"
  1.  S $E(HEADER(4),10)="Date/Time"
  1.  S $E(HEADER(4),30)="LineLabel^Routine"
  1.  S $E(HEADER(4),60)="Error Message"
  1.  ;
  1.  S MAXLINES=IOSL-4,LINES=MAXLINES+10
  1.  S (CNT,ORDERNUM,PG)=0
  1.  S QFLG="NO"
  1.  ;
  1.  F  S ORDERNUM=$O(^XTMP("BLRSGNSP","D",ORDERNUM))  Q:ORDERNUM<1!(QFLG="Q")  D
  1.  . S NOWDTIME=0
  1.  . F  S NOWDTIME=$O(^XTMP("BLRSGNSP","D",ORDERNUM,NOWDTIME))  Q:NOWDTIME<1!(QFLG="Q")  D
  1.  .. S ERRFRTN=""
  1.  .. F  S ERRFRTN=$O(^XTMP("BLRSGNSP","D",ORDERNUM,NOWDTIME,ERRFRTN))  Q:ERRFRTN=""!(QFLG="Q")  D
  1.  ... I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,"NO")  Q:QFLG="Q"
  1.  ... ;
  1.  ... W ORDERNUM
  1.  ... W ?9,NOWDTIME
  1.  ... W ?29,ERRFRTN
  1.  ... ; W ?59,$G(^XTMP(ERRFRTN,NOWDTIME,MSG))
  1.  ... W ?59,$O(^XTMP(ERRFRTN,NOWDTIME,""))   ; IHS/MSC/MKK - LR*5.2*1034
  1.  ... W !
  1.  ... S LINES=LINES+1
  1.  ... S CNT=CNT+1
  1.  ;
  1.  Q:QFLG="Q"
  1.  ;
  1.  W !!,?4,CNT," Entries"
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1.  ;
  1.  ; ============================= UTILITIES =============================
  1.  ;
  1. SETBLRVS(TWO) ; EP - Set BLRVERN variable(s)
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  S:$L($G(TWO)) BLRVERN2=TWO
  1.  Q
  1.  ;
  1. BADSTUFN(MSG) ; EP - Function
  1.  W !!,?4,MSG,"  Routine Ends."
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q ""
  1.  ;
  1. BADENDQ(MSG) ; EP - Function
  1.  W !!,?4,MSG,"  Routine Ends."
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q "Q"