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

BLRSGNSY.m

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