- 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