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