BLRSGNSY ; IHS/OIT/MKK - IHS Lab SiGN or SYmptom ; 31-Jul-2015 06:30 ; MKK
;;5.2;IHS LABORATORY;**1033,1034,1035**;NOV 1, 1997;Build 5
;
; Looks to the patient's problem list (if it exists) to display selection.
; Only displays those problems that have SNOMED codes.
;
; If the patient does not have a problem list, or if all the problems in the
; list do not have SNOMED codes, the routine will require text input and
; retrieve matches from the BSTS terminology server.
;
PEP ; EP
EP ; EP
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
; Required variables are:
; (1) DFN -- Patient Pointer to file 2
; (2) LRORD -- Order Number
; (3) LRODT -- Order Date
; (4) LRSP -- Order Specimen #
; (5) LRTST -- Lab Order Test
;
GETSDIAG(DFN,LRORD,LRODT,LRSP,LRTST,BAILOUT) ; EP - Get & Store Diagnosis
NEW (BAILOUT,DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRORD,LRODT,LRSP,LRTST,PNM,HRCN,U,XPARSYS,XQXFLG)
;
S LRDFN=+$G(^DPT(DFN,"LR"))
;
S PROBSTR=$$CHKITOUT^BLRSGNSU(DFN,LRODT)
;
I PROBSTR="BAILOUT" S BAILOUT=1 Q 1
;
S RELCINFO=""
;
D STORDIAG(DFN,LRORD,LRODT,LRSP,LRTST,PROBSTR,RELCINFO)
;
K ^TMP("BLR SNOMED GET",$J,"HDR")
Q 0
;
ALLTESTS(DFN,LRORD,LRODT) ; EP - Get & Store Single Diagnosis for *ALL* tests on an Order with Multiple Tests
NEW (DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRORD,LRODT,PNM,HRCN,U,XPARSYS,XQXFLG)
;
S BAILOUT=0
;
S LRDFN=+$G(^DPT(DFN,"LR"))
;
S PROBSTR=$$CHKITOUT^BLRSGNSU(DFN,LRODT)
Q:PROBSTR="BAILOUT" 1
;
S RELCINFO=""
;
S LRSP=.9999999
F S LRSP=$O(^LRO(69,"C",LRORD,LRODT,LRSP)) Q:LRSP<1 D
. S LRSPTST=.9999999
. F S LRSPTST=$O(^LRO(69,LRODT,1,LRSP,2,LRSPTST)) Q:LRSPTST<1 D STORDIAG(DFN,LRORD,LRODT,LRSP,LRSPTST,PROBSTR,RELCINFO)
;
K ^TMP("BLR SNOMED GET",$J,"HDR")
Q 0
;
STORDIAG(DFN,LRORD,LRODT,LRSP,LRSPTST,PROBSTR,RELCINFO) ; EP - Store the responses on the test
NEW DESCPROB,ICDSTR,ICDCODE,ICDSTR,IENS,LRTSTF60,SNOMED
;
S SNOMED=$P(PROBSTR,"^") ; SNOMED
S DESCPROB=$P(PROBSTR,"^",2) ; Description of the "Problem"
S ICDCODE=$P(PROBSTR,"^",3) ; ICD
;
; Make sure description has no '(disorder)', etc type of addendum.
S:DESCPROB["(" DESCPROB=$$TRIM^XLFSTR($P(DESCPROB,"("),"LR"," ")
;
D ENTRYAUD^BLRUTIL("STORDIAG^BLRSGNSY 1.0")
;
D ^XBFMK
K FDA,ERRS,IENS
S IENS=LRSPTST_","_LRSP_","_LRODT_","
;
S FDA(69.03,IENS,9999999.1)=DESCPROB
S:$L(SNOMED) FDA(69.03,IENS,9999999.2)=SNOMED
S:$L($G(RELCINFO)) FDA(69.03,IENS,9999999.3)=RELCINFO
D FILE^DIE("EKS","FDA","ERRS")
; I $D(ERRS) D ERRMSG^BLRSGNSP("STORDIAG: FILE^DIE")
I $D(ERRS) D ERRMSG^BLRSGNS3("STORDIAG: FILE^DIE") ; IHS/MSC/MKK - LR*5.2*1035
;
; Q:$$UP^XLFSTR($$ICDDX^ICDCODE(ICDCODE))["INVALID" ; Do not Store 'Invalid Coding System'
;
Q:$$INACTDT^BLRICDU0(ICDCODE,$$DT^XLFDT) ; IHS/MSC/MKK - LR*5.2*1034 -- Do Not Store if ICD currently inactive
;
K FDA,ERRS
S IENS=LRSPTST_","_LRSP_","_LRODT_","
;
I $D(ICDCODE) D
. S ICDIEN=$$FIND1^DIC(80,,"M",ICDCODE_" ")
E S ICDIEN=0
;
K ERRS
S FDA(69.05,"?+1,"_IENS,.01)=ICDCODE
D UPDATE^DIE("EKS","FDA",,"ERRS")
;
I ICDIEN,$D(ERRS) D ; Try using ICD's IEN, if it exists
. K FDA,ERRS
. S FDA(69.05,"?+1,"_IENS,.01)=ICDIEN
. D UPDATE^DIE("S","FDA",,"ERRS")
;
; I $D(ERRS) D ERRMSG^BLRSGNSP("STORDIAG: UPDATE^DIE")
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
; I $D(ERRS) D ERRMSG^BLRSGNSP("STORDIAG: UPDATE^DIE","BLRSGNSY")
I $D(ERRS) D ERRMSG^BLRSGNS3("STORDIAG: UPDATE^DIE","BLRSGNSY") ; IHS/MSC/MKK - LR*5.2*1035
;
D STORDIAG^BLRUTIL6(LRODT,LRSP,LRSPTST,ICDIEN)
;
D ADBLRRLO^BLRUTIL6(LRODT,LRSP,LRSPTST)
; ----- END IHS/MSC/MKK - LR*5.2*1034
Q
;
LISTMSEL() ; EP - LIST Manager to SELect entry
K SNOMED
S (BAILOUT,WHICHONE)=0
F Q:WHICHONE!(BAILOUT) D
. D EN^BLRSM(1)
. I WHICHONE<1 D NEWLIST
;
Q $S(BAILOUT:"BAILOUT",1:$G(SNOMED(WHICHONE)))
;
NEWLIST ; EP - Ask user if they want to create a new listing
NEW ONETEST
;
S ONETEST=+$G(^TMP("BLRDIAG",$J,"ORDER","ADDTST"))
;
S (BAILOUT,Y)=0
F Q:Y!(BAILOUT) D
. W !
. D ^XBFMK
. S DIR(0)="YO"
. S DIR("A")="Create new Listing of SNOMED codes (Y/N)"
. S DIR("B")="YES"
. S DIR("T")=1800 ; IHS/MSC/MKK - LR*5.2*1035 - Wait 30 Minutes
. D ^DIR
. Q:+$G(DIRUT)<1&(+$G(Y))
. ;
. ; User has entered ^ (up-hat) or "NO". One more check
. D ^XBFMK
. S DIR(0)="Y"
. S DIR("A")="Delete "_$S(ONETEST:"Test",1:"Order")_" (Y/N)"
. S DIR("T")=1800 ; IHS/MSC/MKK - LR*5.2*1035 - Wait 30 Minutes
. D ^DIR
. I +$G(Y) S BAILOUT=1 Q
. S Y=0
;
Q:BAILOUT
;
I Y<1!(+$G(DIRUT)) D Q
. W !,"You MUST Select an appropriate SNOMED code from the list."
. D PRESSKEY^BLRGMENU(9)
D GETDIAG^BLRSGNSU(LRODT)
Q
;
RESETSCR ; EP - Reset the screen after a crash
D CLEAR^VALM1
Q
;
GETVALUE(PROBLIEN) ; EP - Get the value to store from the Problem List
S ICDPROB=+$G(^AUPNPROB(PROBLIEN,0))
; S ICDSTR=$$ICDDX^ICDCODE(ICDPROB) ; Currently, ICD Description & Code
S ICDSTR=$$ICDDX^ICDEX(ICDPROB) ; Currently, ICD Description & Code
S ICDCODE=$P(ICDSTR,"^",2),ICDDESC=$P(ICDSTR,"^",4)
Q ICDDESC_"^"_ICDCODE
;
RELCINFO() ; EP - Relevant Clinical Information -- Currently (01/27/2014), not used
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S RELCINFO=""
W !!
D ^XBFMK
S DIR(0)="FO"
S DIR("A")="Relevant Clinical Information (RETURN Exits)"
S DIR("T")=1800 ; IHS/MSC/MKK - LR*5.2*1035 - Wait 30 Minutes
D ^DIR
;
S RELCINFO=$G(X)
;
Q RELCINFO
;
PROVNARR ; EP - List ALL current Provider Narratives for all tests for the order
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
S ORDERN=$G(^TMP("BLRDIAG",$J,"ORDER"))
Q:ORDERN<1
;
S (CNT,LRODT)=0
F S LRODT=$O(^LRO(69,"C",ORDERN,LRODT)) Q:LRODT<1 D
. S LRSP=0
. F S LRSP=$O(^LRO(69,"C",ORDERN,LRODT,LRSP)) Q:LRSP<1 D
.. S LROTST=0
.. F S LROTST=$O(^LRO(69,LRODT,1,LRSP,2,LROTST)) Q:LROTST<1 D
... S IENS=LROTST_","_LRSP_","_LRODT
... S F60DESC=$$GET1^DIQ(69.03,IENS,"TEST/PROCEDURE")
... S PROVNARR=$$GET1^DIQ(69.03,IENS,"PROVIDER NARRATIVE")
... S LRSNOMED=$$GET1^DIQ(69.03,IENS,"SNOMED")
... Q:$L(PROVNARR)<1&($L(LRSNOMED)<1)
... S CNT=CNT+1
... W:CNT=1 "Other Tests' Provider Narrative:",!
... W ?4,"TEST: ",F60DESC,!
... W ?9,"PROVIDER NARRATIVE:"
... D LINEWRAP^BLRGMENU(30,PROVNARR,50)
... W !
... W ?9,"SNOMED: ",LRSNOMED,!
... ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
... S ICD=$$GET1^DIQ(69.05,"1,"_IENS,.01) ; Get 1st ICD code for the test
... W:$L(ICD) ?9,"ICD: ",ICD,!
... ; ----- END IHS/MSC/MKK - LR*5.2*1035
Q
;
DEBUG ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S DFN=11189
S PNM="DEMO,ALISTER LANE"
S HRCN=124625
S LRORD=82
S LRODT=3130801
S LRSP=1
S LRTST=1
S X=$$GETSDIAG(DFN,LRORD,LRODT,LRSP,LRTST)
Q
;
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,X,XPARSYS,XQXFLG)
;
S BLRVERN=$TR($P($T(+1),";")," ")
S BLRVERN2="XTMPMENU"
;
D ADDTMENU^BLRGMENU("XTMPRPT^BLRSGNSY","Date/Time Report")
D ADDTMENU^BLRGMENU("XTMPORPT^BLRSGNSY","Date/Time Report by Order Number")
D ADDTMENU^BLRGMENU("XTMPORDR^BLRSGNSY","Detail data by Order Number")
;
; Main Menu driver
D MENUDRVR^BLRGMENU("RPMS Lab Developer Programs","^XTMP(""BLRSGNSY"" Routines")
Q
;
XTMPRPT ; EP - Report on ^XTMP("BLRSGNSY" data
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
I $D(^XTMP("BLRSGNSY"))<1 D Q
. W !!,"No data in ^XTMP(""BLRSGNSY"". Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
D XTMPRPTI
;
; Reverse $ORDER sort
F S DATETIME=$O(^XTMP("BLRSGNSY",DATETIME),-1) Q:DATETIME<1!(QFLG="Q") D
. S MSG="ZZZZ"
. F S MSG=$O(^XTMP("BLRSGNSY",DATETIME,MSG),-1) Q:MSG=""!(QFLG="Q") D XTMPRPTL
;
D:QFLG'="Q" PRESSKEY^BLRGMENU(9)
;
Q
;
XTMPRPTI ; EP - Initialization
S BLRVERN=$TR($P($T(+1),";")," ")
;
S HEADER(1)="Selection of SNOMED Codes"
S HEADER(2)="Errors Report"
;
D HEADERDT^BLRGMENU
D HEADONE^BLRGMENU(.HDRONE)
;
S HEADER(3)=" "
S $E(HEADER(4),17)="Date/Time"
S $E(HEADER(4),35)="Message"
;
S MAXLINES=20,LINES=MAXLINES+10
S (CNT,PG)=0
S QFLG="NO"
S DATETIME="A"
Q
;
XTMPRPTL ; EP - Line of Data
I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,.HDRONE) Q:QFLG="Q"
;
W DATETIME,?16,$$FMTE^XLFDT(DATETIME,"5MZ")
I $L(MSG)<55 W ?34,MSG
E D LINEWRAP^BLRGMENU(34,MSG,46)
W !
S LINES=LINES+1
S CNT=CNT+1
Q
;
XTMPORPT ; EP - Report on ^XTMP("BLRSGNSY" data by Order Number
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
I $D(^XTMP("BLRSGNSY"))<1 D Q
. W !!,"No data in ^XTMP(""BLRSGNSY"". Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
D XTMPORPI
;
S ORDERNUM="A"
F S ORDERNUM=$O(^XTMP("BLRSGNSY","D",ORDERNUM),-1) Q:ORDERNUM<1!(QFLG="Q") D
. S DATETIME="A"
. F S DATETIME=$O(^XTMP("BLRSGNSY","D",ORDERNUM,DATETIME),-1) Q:DATETIME<1!(QFLG="Q") D
.. S MSG="ZZZZ"
.. F S MSG=$O(^XTMP("BLRSGNSY",DATETIME,MSG),-1) Q:MSG=""!(QFLG="Q") D XTMPORPL
;
D:QFLG'="Q" PRESSKEY^BLRGMENU(9)
;
Q
;
XTMPORPI ; EP - Initialization
S BLRVERN=$TR($P($T(+1),";")," ")
;
S HEADER(1)="Selection of SNOMED Codes"
S HEADER(2)="Errors Report"
;
D HEADERDT^BLRGMENU
D HEADONE^BLRGMENU(.HDRONE)
;
S HEADER(3)=$$CJ^XLFSTR("By Reverse Order Number",IOM)
S HEADER(4)=" "
S HEADER(5)="Order #"
S $E(HEADER(5),10)="FileMan Dt/Time"
S $E(HEADER(5),27)="External Dt/Time"
S $E(HEADER(5),45)="Message"
;
S MAXLINES=20,LINES=MAXLINES+10
S (CNT,PG)=0
S QFLG="NO"
S DATETIME="A"
Q
;
XTMPORPL ; EP - Line of Data
I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,.HDRONE) Q:QFLG="Q"
;
W ORDERNUM,?9,DATETIME,?26,$$FMTE^XLFDT(DATETIME,"5MZ")
I $L(MSG)<45 W ?44,MSG
E D LINEWRAP^BLRGMENU(44,MSG,35)
W !
S LINES=LINES+1
S CNT=CNT+1
Q
BLRSGNSY ; IHS/OIT/MKK - IHS Lab SiGN or SYmptom ; 31-Jul-2015 06:30 ; MKK
+1 ;;5.2;IHS LABORATORY;**1033,1034,1035**;NOV 1, 1997;Build 5
+2 ;
+3 ; Looks to the patient's problem list (if it exists) to display selection.
+4 ; Only displays those problems that have SNOMED codes.
+5 ;
+6 ; If the patient does not have a problem list, or if all the problems in the
+7 ; list do not have SNOMED codes, the routine will require text input and
+8 ; retrieve matches from the BSTS terminology server.
+9 ;
PEP ; EP
EP ; EP
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
+4 ; Required variables are:
+5 ; (1) DFN -- Patient Pointer to file 2
+6 ; (2) LRORD -- Order Number
+7 ; (3) LRODT -- Order Date
+8 ; (4) LRSP -- Order Specimen #
+9 ; (5) LRTST -- Lab Order Test
+10 ;
GETSDIAG(DFN,LRORD,LRODT,LRSP,LRTST,BAILOUT) ; EP - Get & Store Diagnosis
+1 NEW (BAILOUT,DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRORD,LRODT,LRSP,LRTST,PNM,HRCN,U,XPARSYS,XQXFLG)
+2 ;
+3 SET LRDFN=+$GET(^DPT(DFN,"LR"))
+4 ;
+5 SET PROBSTR=$$CHKITOUT^BLRSGNSU(DFN,LRODT)
+6 ;
+7 IF PROBSTR="BAILOUT"
SET BAILOUT=1
QUIT 1
+8 ;
+9 SET RELCINFO=""
+10 ;
+11 DO STORDIAG(DFN,LRORD,LRODT,LRSP,LRTST,PROBSTR,RELCINFO)
+12 ;
+13 KILL ^TMP("BLR SNOMED GET",$JOB,"HDR")
+14 QUIT 0
+15 ;
ALLTESTS(DFN,LRORD,LRODT) ; EP - Get & Store Single Diagnosis for *ALL* tests on an Order with Multiple Tests
+1 NEW (DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRORD,LRODT,PNM,HRCN,U,XPARSYS,XQXFLG)
+2 ;
+3 SET BAILOUT=0
+4 ;
+5 SET LRDFN=+$GET(^DPT(DFN,"LR"))
+6 ;
+7 SET PROBSTR=$$CHKITOUT^BLRSGNSU(DFN,LRODT)
+8 IF PROBSTR="BAILOUT"
QUIT 1
+9 ;
+10 SET RELCINFO=""
+11 ;
+12 SET LRSP=.9999999
+13 FOR
SET LRSP=$ORDER(^LRO(69,"C",LRORD,LRODT,LRSP))
IF LRSP<1
QUIT
Begin DoDot:1
+14 SET LRSPTST=.9999999
+15 FOR
SET LRSPTST=$ORDER(^LRO(69,LRODT,1,LRSP,2,LRSPTST))
IF LRSPTST<1
QUIT
DO STORDIAG(DFN,LRORD,LRODT,LRSP,LRSPTST,PROBSTR,RELCINFO)
End DoDot:1
+16 ;
+17 KILL ^TMP("BLR SNOMED GET",$JOB,"HDR")
+18 QUIT 0
+19 ;
STORDIAG(DFN,LRORD,LRODT,LRSP,LRSPTST,PROBSTR,RELCINFO) ; EP - Store the responses on the test
+1 NEW DESCPROB,ICDSTR,ICDCODE,ICDSTR,IENS,LRTSTF60,SNOMED
+2 ;
+3 ; SNOMED
SET SNOMED=$PIECE(PROBSTR,"^")
+4 ; Description of the "Problem"
SET DESCPROB=$PIECE(PROBSTR,"^",2)
+5 ; ICD
SET ICDCODE=$PIECE(PROBSTR,"^",3)
+6 ;
+7 ; Make sure description has no '(disorder)', etc type of addendum.
+8 IF DESCPROB["("
SET DESCPROB=$$TRIM^XLFSTR($PIECE(DESCPROB,"("),"LR"," ")
+9 ;
+10 DO ENTRYAUD^BLRUTIL("STORDIAG^BLRSGNSY 1.0")
+11 ;
+12 DO ^XBFMK
+13 KILL FDA,ERRS,IENS
+14 SET IENS=LRSPTST_","_LRSP_","_LRODT_","
+15 ;
+16 SET FDA(69.03,IENS,9999999.1)=DESCPROB
+17 IF $LENGTH(SNOMED)
SET FDA(69.03,IENS,9999999.2)=SNOMED
+18 IF $LENGTH($GET(RELCINFO))
SET FDA(69.03,IENS,9999999.3)=RELCINFO
+19 DO FILE^DIE("EKS","FDA","ERRS")
+20 ; I $D(ERRS) D ERRMSG^BLRSGNSP("STORDIAG: FILE^DIE")
+21 ; IHS/MSC/MKK - LR*5.2*1035
IF $DATA(ERRS)
DO ERRMSG^BLRSGNS3("STORDIAG: FILE^DIE")
+22 ;
+23 ; Q:$$UP^XLFSTR($$ICDDX^ICDCODE(ICDCODE))["INVALID" ; Do not Store 'Invalid Coding System'
+24 ;
+25 ; IHS/MSC/MKK - LR*5.2*1034 -- Do Not Store if ICD currently inactive
IF $$INACTDT^BLRICDU0(ICDCODE,$$DT^XLFDT)
QUIT
+26 ;
+27 KILL FDA,ERRS
+28 SET IENS=LRSPTST_","_LRSP_","_LRODT_","
+29 ;
+30 IF $DATA(ICDCODE)
Begin DoDot:1
+31 SET ICDIEN=$$FIND1^DIC(80,,"M",ICDCODE_" ")
End DoDot:1
+32 IF '$TEST
SET ICDIEN=0
+33 ;
+34 KILL ERRS
+35 SET FDA(69.05,"?+1,"_IENS,.01)=ICDCODE
+36 DO UPDATE^DIE("EKS","FDA",,"ERRS")
+37 ;
+38 ; Try using ICD's IEN, if it exists
IF ICDIEN
IF $DATA(ERRS)
Begin DoDot:1
+39 KILL FDA,ERRS
+40 SET FDA(69.05,"?+1,"_IENS,.01)=ICDIEN
+41 DO UPDATE^DIE("S","FDA",,"ERRS")
End DoDot:1
+42 ;
+43 ; I $D(ERRS) D ERRMSG^BLRSGNSP("STORDIAG: UPDATE^DIE")
+44 ;
+45 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
+46 ; I $D(ERRS) D ERRMSG^BLRSGNSP("STORDIAG: UPDATE^DIE","BLRSGNSY")
+47 ; IHS/MSC/MKK - LR*5.2*1035
IF $DATA(ERRS)
DO ERRMSG^BLRSGNS3("STORDIAG: UPDATE^DIE","BLRSGNSY")
+48 ;
+49 DO STORDIAG^BLRUTIL6(LRODT,LRSP,LRSPTST,ICDIEN)
+50 ;
+51 DO ADBLRRLO^BLRUTIL6(LRODT,LRSP,LRSPTST)
+52 ; ----- END IHS/MSC/MKK - LR*5.2*1034
+53 QUIT
+54 ;
LISTMSEL() ; EP - LIST Manager to SELect entry
+1 KILL SNOMED
+2 SET (BAILOUT,WHICHONE)=0
+3 FOR
IF WHICHONE!(BAILOUT)
QUIT
Begin DoDot:1
+4 DO EN^BLRSM(1)
+5 IF WHICHONE<1
DO NEWLIST
End DoDot:1
+6 ;
+7 QUIT $SELECT(BAILOUT:"BAILOUT",1:$GET(SNOMED(WHICHONE)))
+8 ;
NEWLIST ; EP - Ask user if they want to create a new listing
+1 NEW ONETEST
+2 ;
+3 SET ONETEST=+$GET(^TMP("BLRDIAG",$JOB,"ORDER","ADDTST"))
+4 ;
+5 SET (BAILOUT,Y)=0
+6 FOR
IF Y!(BAILOUT)
QUIT
Begin DoDot:1
+7 WRITE !
+8 DO ^XBFMK
+9 SET DIR(0)="YO"
+10 SET DIR("A")="Create new Listing of SNOMED codes (Y/N)"
+11 SET DIR("B")="YES"
+12 ; IHS/MSC/MKK - LR*5.2*1035 - Wait 30 Minutes
SET DIR("T")=1800
+13 DO ^DIR
+14 IF +$GET(DIRUT)<1&(+$GET(Y))
QUIT
+15 ;
+16 ; User has entered ^ (up-hat) or "NO". One more check
+17 DO ^XBFMK
+18 SET DIR(0)="Y"
+19 SET DIR("A")="Delete "_$SELECT(ONETEST:"Test",1:"Order")_" (Y/N)"
+20 ; IHS/MSC/MKK - LR*5.2*1035 - Wait 30 Minutes
SET DIR("T")=1800
+21 DO ^DIR
+22 IF +$GET(Y)
SET BAILOUT=1
QUIT
+23 SET Y=0
End DoDot:1
+24 ;
+25 IF BAILOUT
QUIT
+26 ;
+27 IF Y<1!(+$GET(DIRUT))
Begin DoDot:1
+28 WRITE !,"You MUST Select an appropriate SNOMED code from the list."
+29 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+30 DO GETDIAG^BLRSGNSU(LRODT)
+31 QUIT
+32 ;
RESETSCR ; EP - Reset the screen after a crash
+1 DO CLEAR^VALM1
+2 QUIT
+3 ;
GETVALUE(PROBLIEN) ; EP - Get the value to store from the Problem List
+1 SET ICDPROB=+$GET(^AUPNPROB(PROBLIEN,0))
+2 ; S ICDSTR=$$ICDDX^ICDCODE(ICDPROB) ; Currently, ICD Description & Code
+3 ; Currently, ICD Description & Code
SET ICDSTR=$$ICDDX^ICDEX(ICDPROB)
+4 SET ICDCODE=$PIECE(ICDSTR,"^",2)
SET ICDDESC=$PIECE(ICDSTR,"^",4)
+5 QUIT ICDDESC_"^"_ICDCODE
+6 ;
RELCINFO() ; EP - Relevant Clinical Information -- Currently (01/27/2014), not used
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 SET RELCINFO=""
+4 WRITE !!
+5 DO ^XBFMK
+6 SET DIR(0)="FO"
+7 SET DIR("A")="Relevant Clinical Information (RETURN Exits)"
+8 ; IHS/MSC/MKK - LR*5.2*1035 - Wait 30 Minutes
SET DIR("T")=1800
+9 DO ^DIR
+10 ;
+11 SET RELCINFO=$GET(X)
+12 ;
+13 QUIT RELCINFO
+14 ;
PROVNARR ; EP - List ALL current Provider Narratives for all tests for the order
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 SET ORDERN=$GET(^TMP("BLRDIAG",$JOB,"ORDER"))
+3 IF ORDERN<1
QUIT
+4 ;
+5 SET (CNT,LRODT)=0
+6 FOR
SET LRODT=$ORDER(^LRO(69,"C",ORDERN,LRODT))
IF LRODT<1
QUIT
Begin DoDot:1
+7 SET LRSP=0
+8 FOR
SET LRSP=$ORDER(^LRO(69,"C",ORDERN,LRODT,LRSP))
IF LRSP<1
QUIT
Begin DoDot:2
+9 SET LROTST=0
+10 FOR
SET LROTST=$ORDER(^LRO(69,LRODT,1,LRSP,2,LROTST))
IF LROTST<1
QUIT
Begin DoDot:3
+11 SET IENS=LROTST_","_LRSP_","_LRODT
+12 SET F60DESC=$$GET1^DIQ(69.03,IENS,"TEST/PROCEDURE")
+13 SET PROVNARR=$$GET1^DIQ(69.03,IENS,"PROVIDER NARRATIVE")
+14 SET LRSNOMED=$$GET1^DIQ(69.03,IENS,"SNOMED")
+15 IF $LENGTH(PROVNARR)<1&($LENGTH(LRSNOMED)<1)
QUIT
+16 SET CNT=CNT+1
+17 IF CNT=1
WRITE "Other Tests' Provider Narrative:",!
+18 WRITE ?4,"TEST: ",F60DESC,!
+19 WRITE ?9,"PROVIDER NARRATIVE:"
+20 DO LINEWRAP^BLRGMENU(30,PROVNARR,50)
+21 WRITE !
+22 WRITE ?9,"SNOMED: ",LRSNOMED,!
+23 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
+24 ; Get 1st ICD code for the test
SET ICD=$$GET1^DIQ(69.05,"1,"_IENS,.01)
+25 IF $LENGTH(ICD)
WRITE ?9,"ICD: ",ICD,!
+26 ; ----- END IHS/MSC/MKK - LR*5.2*1035
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
DEBUG ; EP
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 SET DFN=11189
+4 SET PNM="DEMO,ALISTER LANE"
+5 SET HRCN=124625
+6 SET LRORD=82
+7 SET LRODT=3130801
+8 SET LRSP=1
+9 SET LRTST=1
+10 SET X=$$GETSDIAG(DFN,LRORD,LRODT,LRSP,LRTST)
+11 QUIT
+12 ;
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,X,XPARSYS,XQXFLG)
+2 ;
+3 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+4 SET BLRVERN2="XTMPMENU"
+5 ;
+6 DO ADDTMENU^BLRGMENU("XTMPRPT^BLRSGNSY","Date/Time Report")
+7 DO ADDTMENU^BLRGMENU("XTMPORPT^BLRSGNSY","Date/Time Report by Order Number")
+8 DO ADDTMENU^BLRGMENU("XTMPORDR^BLRSGNSY","Detail data by Order Number")
+9 ;
+10 ; Main Menu driver
+11 DO MENUDRVR^BLRGMENU("RPMS Lab Developer Programs","^XTMP(""BLRSGNSY"" Routines")
+12 QUIT
+13 ;
XTMPRPT ; EP - Report on ^XTMP("BLRSGNSY" data
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 IF $DATA(^XTMP("BLRSGNSY"))<1
Begin DoDot:1
+4 WRITE !!,"No data in ^XTMP(""BLRSGNSY"". Routine Ends."
+5 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+6 ;
+7 DO XTMPRPTI
+8 ;
+9 ; Reverse $ORDER sort
+10 FOR
SET DATETIME=$ORDER(^XTMP("BLRSGNSY",DATETIME),-1)
IF DATETIME<1!(QFLG="Q")
QUIT
Begin DoDot:1
+11 SET MSG="ZZZZ"
+12 FOR
SET MSG=$ORDER(^XTMP("BLRSGNSY",DATETIME,MSG),-1)
IF MSG=""!(QFLG="Q")
QUIT
DO XTMPRPTL
End DoDot:1
+13 ;
+14 IF QFLG'="Q"
DO PRESSKEY^BLRGMENU(9)
+15 ;
+16 QUIT
+17 ;
XTMPRPTI ; EP - Initialization
+1 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+2 ;
+3 SET HEADER(1)="Selection of SNOMED Codes"
+4 SET HEADER(2)="Errors Report"
+5 ;
+6 DO HEADERDT^BLRGMENU
+7 DO HEADONE^BLRGMENU(.HDRONE)
+8 ;
+9 SET HEADER(3)=" "
+10 SET $EXTRACT(HEADER(4),17)="Date/Time"
+11 SET $EXTRACT(HEADER(4),35)="Message"
+12 ;
+13 SET MAXLINES=20
SET LINES=MAXLINES+10
+14 SET (CNT,PG)=0
+15 SET QFLG="NO"
+16 SET DATETIME="A"
+17 QUIT
+18 ;
XTMPRPTL ; EP - Line of Data
+1 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,.HDRONE)
IF QFLG="Q"
QUIT
+2 ;
+3 WRITE DATETIME,?16,$$FMTE^XLFDT(DATETIME,"5MZ")
+4 IF $LENGTH(MSG)<55
WRITE ?34,MSG
+5 IF '$TEST
DO LINEWRAP^BLRGMENU(34,MSG,46)
+6 WRITE !
+7 SET LINES=LINES+1
+8 SET CNT=CNT+1
+9 QUIT
+10 ;
XTMPORPT ; EP - Report on ^XTMP("BLRSGNSY" data by Order Number
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 IF $DATA(^XTMP("BLRSGNSY"))<1
Begin DoDot:1
+4 WRITE !!,"No data in ^XTMP(""BLRSGNSY"". Routine Ends."
+5 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+6 ;
+7 DO XTMPORPI
+8 ;
+9 SET ORDERNUM="A"
+10 FOR
SET ORDERNUM=$ORDER(^XTMP("BLRSGNSY","D",ORDERNUM),-1)
IF ORDERNUM<1!(QFLG="Q")
QUIT
Begin DoDot:1
+11 SET DATETIME="A"
+12 FOR
SET DATETIME=$ORDER(^XTMP("BLRSGNSY","D",ORDERNUM,DATETIME),-1)
IF DATETIME<1!(QFLG="Q")
QUIT
Begin DoDot:2
+13 SET MSG="ZZZZ"
+14 FOR
SET MSG=$ORDER(^XTMP("BLRSGNSY",DATETIME,MSG),-1)
IF MSG=""!(QFLG="Q")
QUIT
DO XTMPORPL
End DoDot:2
End DoDot:1
+15 ;
+16 IF QFLG'="Q"
DO PRESSKEY^BLRGMENU(9)
+17 ;
+18 QUIT
+19 ;
XTMPORPI ; EP - Initialization
+1 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+2 ;
+3 SET HEADER(1)="Selection of SNOMED Codes"
+4 SET HEADER(2)="Errors Report"
+5 ;
+6 DO HEADERDT^BLRGMENU
+7 DO HEADONE^BLRGMENU(.HDRONE)
+8 ;
+9 SET HEADER(3)=$$CJ^XLFSTR("By Reverse Order Number",IOM)
+10 SET HEADER(4)=" "
+11 SET HEADER(5)="Order #"
+12 SET $EXTRACT(HEADER(5),10)="FileMan Dt/Time"
+13 SET $EXTRACT(HEADER(5),27)="External Dt/Time"
+14 SET $EXTRACT(HEADER(5),45)="Message"
+15 ;
+16 SET MAXLINES=20
SET LINES=MAXLINES+10
+17 SET (CNT,PG)=0
+18 SET QFLG="NO"
+19 SET DATETIME="A"
+20 QUIT
+21 ;
XTMPORPL ; EP - Line of Data
+1 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLG,.HDRONE)
IF QFLG="Q"
QUIT
+2 ;
+3 WRITE ORDERNUM,?9,DATETIME,?26,$$FMTE^XLFDT(DATETIME,"5MZ")
+4 IF $LENGTH(MSG)<45
WRITE ?44,MSG
+5 IF '$TEST
DO LINEWRAP^BLRGMENU(44,MSG,35)
+6 WRITE !
+7 SET LINES=LINES+1
+8 SET CNT=CNT+1
+9 QUIT
