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