BLRSGNSU ; IHS/OIT/MKK - IHS Lab SiGN or SYmptom Utilities ; 31-Jul-2015 06:30 ; MKK
;;5.2;IHS LABORATORY;**1033,1034,1035**;NOV 1, 1997;Build 5
;
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
; Called from ADDTST^BLRDIAG
CHKORDAC(LRODT,ORDIEN,TST) ; EP - Adding a test?
D ENTRYAUD^BLRUTIL("CHKORDAC^BLRSGNSU 0.0")
;
Q:$$ADDTLRAS(LRODT,ORDIEN,TST) 1
;
Q:$$ACCESST(LRODT,ORDIEN,TST) 0 ; IHS/MSC/MKK - LR*5.2*1034 - Accession on Order, exit
;
Q:$$ADDTORDN(LRODT,ORDIEN,TST) 1 ; IHS/MSC/MKK - LR*5.2*1034 - Only orders
;
Q 0
;
ADDTLRAS(LRODT,LRSP,LRTST) ; EP - Adding a test to an accession?
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)
;
D ENTRYAUD^BLRUTIL("ADDTLRAS^BLRSGNSU 0.0")
;
S LRASTEST=$$ACCESST(LRODT,LRSP,LRTST) ; Get first test on order with Accession data
Q:LRASTEST<1 0
;
S IENS=LRASTEST_","_LRSP_","_LRODT_","
;
S ORIGPN=$$GET1^DIQ(69.03,IENS,"PROVIDER NARRATIVE")
S ORIGSN=$$GET1^DIQ(69.03,IENS,"SNOMED")
S ORIGICDP=$$GET1^DIQ(69.05,1_","_IENS,"ICD CODES")
S ORIGICDI=+$$GET1^DIQ(69.05,1_","_IENS,"ICD CODES","I")
;
; Q:$L(ORIGPN)<1!($L(ORIGSN)<1) 0 ; If no data to copy, quit
Q:$L(ORIGPN)<1&($L(ORIGSN)<1) 0 ; IHS/MSC/MKK - LR*5.2*1035 -- If no data to copy, quit
;
S LRNEWTST=+$O(^LRO(69,LRODT,1,LRSP,2,"B",LRTST,0))
S IENS=LRNEWTST_","_LRSP_","_LRODT_","
;
; S FDA(69.03,IENS,9999999.1)=ORIGPN
; S FDA(69.03,IENS,9999999.2)=ORIGSN
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
; Data Can be either SNOMED or PROVIDER NARRATIVE or both
S:$L(ORIGPN) FDA(69.03,IENS,9999999.1)=ORIGPN
S:$L(ORIGSN) FDA(69.03,IENS,9999999.2)=ORIGSN
; ----- END IHS/MSC/MKK - LR*5.2*1035
;
D UPDATE^DIE("EKS","FDA",,"ERRS")
; I $D(ERRS) D ERRMSG^BLRSGNSP("ADDTLRAS: UPDATE^DIE","BLRSGNSU")
I $D(ERRS) D ERRMSG^BLRSGNS3("ADDTLRAS: 69.03 UPDATE^DIE","BLRSGNSU") ; IHS/MSC/MKK - LR*5.2*1035
;
K FDA,ERRS
S FDA(69.05,"?+1,"_IENS,.01)=ORIGICDP
; D UPDATE^DIE("EKS","FDA",,"ERRS")
D:$L(ORIGICDP) UPDATE^DIE("EKS","FDA",,"ERRS") ; IHS/MSC/MKK - LR*5.2*1035 -- UPDATE IFF ORIGICDP variable has data
;
I $D(ERRS),ORIGICDI D ; If Error, try using ICD's IEN, if it exists
. K FDA,ERRS
. S FDA(69.05,"?+1,"_IENS,.01)=ORIGICDI
. D UPDATE^DIE("S","FDA",,"ERRS")
;
; I $D(ERRS) D ERRMSG^BLRSGNSP("ADDTLRAS: UPDATE^DIE","BLRSGNSU")
I $D(ERRS) D ERRMSG^BLRSGNS3("ADDTLRAS: UPDATE^DIE","BLRSGNSU") ; IHS/MSC/MKK - LR*5.2*1035
Q 1
;
ACCESST(LRODT,LRSP,ORDTEST) ; EP - Determine the first test on an order with Accession data
NEW IENS,ORDTEST,LRASTEST
;
S (ORDTEST,LRASTEST)=0
F S ORDTEST=$O(^LRO(69,LRODT,1,LRSP,2,ORDTEST)) Q:ORDTEST<1!(LRASTEST) D
. S IENS=ORDTEST_","_LRSP_","_LRODT
. Q:$$GET1^DIQ(69.03,IENS,9999999.2)="" ; LR*5.2*1035 - If no SNOMED, go to next test
. ;
. S:+$$GET1^DIQ(69.03,IENS,"ACCESSION DATE","I") LRASTEST=ORDTEST
;
Q LRASTEST
;
; Called from ADDTST^BLRDIAG
ADDTORDN(LRODT,LRSP,LRTST) ; EP - Adding a test to an order?
; 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)
NEW (BAILOUT,DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,LRORD,LRODT,LRSP,LRTST,PNM,HRCN,U,XPARSYS,XQXFLG)
;
D HOME^%ZIS
;
D ENTRYAUD^BLRUTIL("ADDTORDN^BLRSGNSU 0.0")
S ORDERN=$$GET1^DIQ(69.01,LRSP_","_LRODT,"ORDER #")
;
Q:+ORDERN<1 0 ; Skip if no Order #
;
S DIRZERO="SO^"
S (CNT,FOUNDIT,LR69ODT)=0
F S LR69ODT=$O(^LRO(69,"C",ORDERN,LR69ODT)) Q:LR69ODT<1 D
. S LR69SP=0
. F S LR69SP=$O(^LRO(69,"C",ORDERN,LR69ODT,LR69SP)) Q:LR69SP<1 D
.. S LROTST=0
.. F S LROTST=$O(^LRO(69,LR69ODT,1,LR69SP,2,LROTST)) Q:LROTST<1 D
... S IENS=LROTST_","_LR69SP_","_LR69ODT
... 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 FOUNDIT=FOUNDIT+1
... S CNT=CNT+1
... S ORDTEST(CNT)=LROTST_","_LR69SP_","_LR69ODT
... S DIRZERO=DIRZERO_CNT_":"_CNT_";"
... K STR
... S STR=$J(CNT,2)
... S $E(STR,5)=$E(F60DESC,1,18)
... S $E(STR,25)=LRSNOMED
... ; S $E(STR,41)=$E(PROVNARR,1,40)
... ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
... S $E(STR,40)=$E(PROVNARR,1,31)
... S ICDCODE=$$GET1^DIQ(69.05,"1,"_IENS,.01)
... S:$L(ICDCODE) $E(STR,73)=ICDCODE
... ; ----- END IHS/MSC/MKK - LR*5.2*1035
... S DIRZERO(CNT)=STR
;
Q:FOUNDIT<1 0 ; Skip -- No Data found on any of the other tests
;
S CNT=CNT+1
S DIRZERO=DIRZERO_(CNT)_":NA"
S LASTCNT=CNT
;
D ^XBFMK
S DIR(0)=DIRZERO
; S DIR("L",1)=" TEST SNOMED PROVIDER NARRATIVE"
; S DIR("L",2)=" ------------------ ------------- ----------------------------------------"
; ----- BEGIN IHS/MSC/MKK LR*5.2*1035
; 12345678901234567890123456789012345678901234567890123456789012345678901234567890
S DIR("L",1)=" TEST SNOMED PROVIDER NARRATIVE ICD"
S DIR("L",2)=" ------------------ ------------- ------------------------------- --------"
; ----- END IHS/MSC/MKK LR*5.2*1035
S (CNT,MENUCNT)=0
F S CNT=$O(DIRZERO(CNT)) Q:CNT<1 D
. S DIR("L",CNT+2)=$G(DIRZERO(CNT))
. S MENUCNT=CNT
S MENUCNT=MENUCNT+1
S DIR("L",MENUCNT+2)=" "
S MENUCNT=MENUCNT+1
K STR
S STR=$J(LASTCNT,2)
S $E(STR,5)="None of the Above"
S DIR("L",MENUCNT+2)=STR
;
S DIR("L")=""
S DIR("A")="Select number" ; Change default prompt
;
S ADDTSTPN=$$GET1^DIQ(60,LRTST,"PRINT NAME")
S HEADER(1)="Lab Order Entry (#69)"
S HEADER(2)="Adding Test "_ADDTSTPN_" ["_LRTST_"] to Order # "_ORDERN
S HEADER(3)=$$CJ^XLFSTR("Selecting SNOMED",IOM)
;
D HEADERDT^BLRGMENU
;
D ^DIR
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
I +$G(ORDTEST(+Y))<1 D Q 0
. W !!,?4,"No/Invalid/Quit Entry."
. D PRESSKEY^BLRGMENU(9)
; ----- END IHS/MSC/MKK - LR*5.2*1035
;
I Y=LASTCNT D Q 0
. W !!,?4,"'None of the Above' Selected. Terminology Server will be called."
. D PRESSKEY^BLRGMENU(9)
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
; Moved this code above
; I +$G(ORDTEST(Y))<1 D Q 0
; . W !!,?4,"No/Invalid/Quit Entry."
; . D PRESSKEY^BLRGMENU(9)
; ----- END IHS/MSC/MKK - LR*5.2*1035
;
S IENS=$G(ORDTEST(Y))
;
S ORIGPN=$$GET1^DIQ(69.03,IENS,"PROVIDER NARRATIVE")
S ORIGSN=$$GET1^DIQ(69.03,IENS,"SNOMED")
S ORIGICDP=$$GET1^DIQ(69.05,"1,"_IENS,"ICD CODES")
;
Q:$L(ORIGPN)<1!($L(ORIGSN)<1) 0 ; If no data to copy, quit
;
S LRNEWTST=+$O(^LRO(69,LRODT,1,LRSP,2,"B",LRTST,0))
S IENS=LRNEWTST_","_LRSP_","_LRODT_","
;
S FDA(69.03,IENS,9999999.1)=ORIGPN
S FDA(69.03,IENS,9999999.2)=ORIGSN
S:$L(ORIGICDP) FDA(69.05,"?+1,"_IENS,.01)=ORIGICDP
D UPDATE^DIE("EKS","FDA",,"ERRS")
;
I $D(ERRS) D Q 0
. W !!,?4,"Error trying to add data. See MailMan message."
. D PRESSKEY^BLRGMENU(9)
. ; D ERRMSG^BLRSGNSP("ADDTLRAS: UPDATE^DIE","BLRSGNSU")
. D ERRMSG^BLRSGNS3("ADDTLRAS: UPDATE^DIE","BLRSGNSU") ; IHS/MSC/MKK - LR*5.2*1035
;
S ADDTESTN=$$GET1^DIQ(60,LRTST,"NAME")
W !!,?4,"SNOMED ",ORIGSN," data added to test "_ADDTESTN_" ["_LRTST_"]."
D PRESSKEY^BLRGMENU(9)
;
Q 1 ; Successfully added entry
;
; Subroutines moved from BLRSGNSY to here because BLRSGNSY became too large
CHKITOUT(DFN,LRODT) ; EP - User MUST select a diagnosis from list
Q:$$CHKPLIST(DFN,LRODT)<1 $$TEXTPOVI(DFN,LRODT) ; Check Problem List. If zero, use TEXTPOVI function
;
NEW (DFN,DEBUG,DILOCKTM,DISYS,DT,DTIME,DUZ,HRCN,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRODT,PNM,U,XPARSYS,XQXFLG)
;
Q $$GETSNOPN(DFN,LRODT) ; Use SNOMED codes & Provider Narrative
;
CHKPLIST(DFN,LRODT) ; EP - Check Problem List.
NEW APISTR,ONLYONE,PROBICD,PROBCNT,PROBIEN,PSTATUS
;
S PROBCNT=0,PROBICD="",PROBIEN="AAA"
F S PROBIEN=$O(^AUPNPROB("AC",DFN,PROBIEN),-1) Q:PROBIEN<1 D
. S CONCID=$$GET1^DIQ(9000011,PROBIEN,"SNOMED CT CONCEPT CODE","I")
. Q:CONCID<1
. ;
. S PSTATUS=$$GET1^DIQ(9000011,PROBIEN,"STATUS","I")
. Q:PSTATUS="I"!(PSTATUS="D") ; If problem's status is INACTIVE or DELETED, skip
. ;
. S $P(CONCID,"^",3)=LRODT ; Make sure current codes as of Order's date are returned
. ; S APISTR=$$CONC^BSTSAPI(CONCID) ; Return Data from Terminology Server
. S APISTR=$$CONC^BSTSAPI(CONCID_"^^^1") ; Search for Data from Terminology Server's local cache first -- LR*5.2*1034
. S:$L($TR(APISTR,"^"))<1 APISTR=$$CONC^BSTSAPI(CONCID) ; If no local cache data, return Data from Terminology Server -- LR*5.2*1034
. S PROBICD=$P($P(APISTR,"^",5),";")
. ; Q:$E(PROBICD)="Z" ; Skip if ICD code begins with "Z"
. ; Q:PROBICD=799.9 ; Skip if ICD code is a place holder
. ; Q:PROBICD=.9999 ; Skip if ICD code is invalid
. ;
. S PROBCNT=PROBCNT+1
;
Q PROBCNT
;
; The following code reads the patient's entries in the PROBLEM file, uses the SNOMED Code
; and creates the necessary string for ListMan.
GETSNOPN(DFN,LRODT) ; EP - SNOMED Selections
NEW APISTR,ENTERDT,ICDCODE,ICDDESC,ICDPROB,ICDSTR,IEN,IN,LASTMODD,PROBICD,PROBCNT,PROBIEN,PROBLEMS,SNOMED,SNOMEDSC,VARS,VARSDESC
;
S PROBIEN="AAA",OUT="VARSDESC",CNT=0
F S PROBIEN=$O(^AUPNPROB("AC",DFN,PROBIEN),-1) Q:PROBIEN<1 D
. S CONCID=$$GET1^DIQ(9000011,PROBIEN,"SNOMED CT CONCEPT CODE","I")
. Q:CONCID<1
. ;
. S PSTATUS=$$GET1^DIQ(9000011,PROBIEN,"STATUS","I")
. Q:PSTATUS="I"!(PSTATUS="D") ; If problem's status is INACTIVE or DELETED, skip
. ;
. S $P(CONCID,"^",3)=LRODT ; Make sure current codes as of Order's date are returned
. ; S APISTR=$$CONC^BSTSAPI(CONCID) ; Return Data from Terminology Server
. S APISTR=$$CONC^BSTSAPI(CONCID_"^^^1") ; Search for Data from Terminology Server's local cache first -- LR*5.2*1034
. S:$L($TR(APISTR,"^"))<1 APISTR=$$CONC^BSTSAPI(CONCID) ; If no local cache data, return Data from Terminology Server -- LR*5.2*1034
. S ICDCODE=$P($P(APISTR,"^",5),";")
. ; Q:$E(ICDCODE)="Z" ; Skip if ICD code begins with "Z"
. ; Q:ICDCODE=799.9 ; Skip if ICD code is a place holder
. ; Q:ICDCODE=.9999 ; Skip if ICD code is invalid
. ;
. S SNOMED=$P(APISTR,"^",3)
. S SNOMEDSC=$P(APISTR,"^",4)
. ;
. S CNT=CNT+1
. S VARS(CNT,"PRB","DSC")=SNOMED
. S VARS(CNT,"PRB","TRM")=SNOMEDSC
. S VARS(CNT,"ICD",1,"COD")=ICDCODE
;
; S ^TMP("BLR SNOMED GET",$J,"HDR")="You MUST Select an appropriate SNOMED code from the Patient's Problem List."
S ^TMP("BLR SNOMED GET",$J,"HDR")="Select an appropriate SNOMED code from the Patient's "_CNT_" Problems." ; IHS/MSC/MKK - LR*5.2*1035
Q $$LISTMSEL^BLRSGNSY()
;
TEXTPOVI(DFN,LRODT) ; EP - No Entries in PROBLEM file; use Text & BSTS Database
NEW (DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,HRCN,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRODT,PNM,U,XPARSYS,XQXFLG)
;
I +$G(DFN) D ; Do "banner" like notice to user
. W !!,?4,$TR($J("",67)," ","*"),!
. W ?4,"** Patient has no entries in the PROBLEM File with SNOMED codes. **",!
. W ?4,$TR($J("",67)," ","*"),!!
;
D GETDIAG(LRODT)
Q:+$G(BAILOUT) "BAILOUT"
;
S ^TMP("BLR SNOMED GET",$J,"HDR")="You MUST Select an appropriate SNOMED code."
Q $$LISTMSEL^BLRSGNSY()
;
GETDIAG(LRODT) ; EP - Get a diagnosis.
NEW ONETEST
;
S ONETEST=+$G(^TMP("BLRDIAG",$J,"ORDER","ADDTST"))
;
S (BAILOUT,Y)=0
F Q:Y!(BAILOUT) D
. W !!
. D PROVNARR^BLRSGNSY
. D ^XBFMK
. S DIR(0)="F"
. S DIR("A")="Enter Clinical Indication (Free Text)"
. S DIR("T")=1800 ; IHS/MSC/MKK - LR*5.2*1035 - Wait 30 Minutes
. D ^DIR
. I $G(X)="^^^^^" S Y=99999999 Q ; Trick to exit
. ;
. I $L(X)<1 D Q
.. W !!,?4,"Invalid. Must Enter a Clinical Indication.",!
.. D PRESSKEY^BLRGMENU(9)
.. S Y=0
. I +$G(DUOUT) D Q
.. D ^XBFMK
.. S DIR(0)="Y"
.. ; S DIR("A")="Delete Order (Y/N)"
.. S DIR("A")="Delete "_$S(ONETEST:"Test",1:"Order")_" (Y/N)"
.. S DIR("B")="NO"
.. S DIR("T")=1800 ; IHS/MSC/MKK - LR*5.2*1035 - Wait 30 Minutes
.. D ^DIR
.. I Y=1 S BAILOUT=1,Y=0
.. E S Y=0
. K OUT
. S OUT="VARS",IN=$G(X)_"^S"
. S $P(IN,"^",5)=LRODT ; Make certain current codes returned
. S $P(IN,"^",6)=200,$P(IN,"^",8)=1
. S Y=$$SEARCH^BSTSAPI(OUT,IN)
. D ADDICD9
. I Y<1 W !!,?9,"No entries found in the IHS STANDARD TERMINOLOGY database. Try Again."
;
D:BAILOUT GETRID^BLRSGNSP($G(^TMP("BLRDIAG",$J,"ORDER")))
S:Y=99999999 BAILOUT=1
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
S VARSCNT=$O(VARS("A"),-1)
S ^TMP("BLR SNOMED GET",$J,"HDR")="Select an appropriate SNOMED code from the "_VARSCNT_" retrieved."
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
;
Q
;
ADDICD9 ; EP - Adds ICD9 codes to VARS array
Q ; IHS/MSC/MKK - LR*5.2*1035 -- Do *NOT* add the ICD9 codes
;
NEW WOT,ICD10DT,ICD10PTR,TODAY
;
S ICD10PTR=+$$FIND1^DIC(80.4,,,"ICD-10-CM")
S ICD10DT=+$P($$GET1^DIQ(80.4,ICD10PTR,"IMPLEMENTATION DATE","I"),".")
S:ICD10DT<1 ICD10DT=3151001 ; If no ICD10DT, hard set to 10/1/2015.
S TODAY=$$DT^XLFDT
;
; Q:TODAY'<ICD10DT ; Skip if after ICD-10 "start date" - IHS/MSC/MKK - LR*5.2*1034
;
S WOT=0
F S WOT=$O(VARS(WOT)) Q:WOT<1 D
. Q:$D(VARS(WOT,"ICD")) ; If ICD code, just return
. ;
. S VARS(WOT,"ICD",1,"COD")=$S(TODAY<ICD10DT:".9999",1:"ZZZ.999")
. S VARS(WOT,"ICD",1,"TYP")=$S(TODAY<ICD10DT:"ICD",1:"10D")
;
Q
BLRSGNSU ; IHS/OIT/MKK - IHS Lab SiGN or SYmptom Utilities ; 31-Jul-2015 06:30 ; MKK
+1 ;;5.2;IHS LABORATORY;**1033,1034,1035**;NOV 1, 1997;Build 5
+2 ;
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
+4 ; Called from ADDTST^BLRDIAG
CHKORDAC(LRODT,ORDIEN,TST) ; EP - Adding a test?
+1 DO ENTRYAUD^BLRUTIL("CHKORDAC^BLRSGNSU 0.0")
+2 ;
+3 IF $$ADDTLRAS(LRODT,ORDIEN,TST)
QUIT 1
+4 ;
+5 ; IHS/MSC/MKK - LR*5.2*1034 - Accession on Order, exit
IF $$ACCESST(LRODT,ORDIEN,TST)
QUIT 0
+6 ;
+7 ; IHS/MSC/MKK - LR*5.2*1034 - Only orders
IF $$ADDTORDN(LRODT,ORDIEN,TST)
QUIT 1
+8 ;
+9 QUIT 0
+10 ;
ADDTLRAS(LRODT,LRSP,LRTST) ; EP - Adding a test to an accession?
+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 DO ENTRYAUD^BLRUTIL("ADDTLRAS^BLRSGNSU 0.0")
+4 ;
+5 ; Get first test on order with Accession data
SET LRASTEST=$$ACCESST(LRODT,LRSP,LRTST)
+6 IF LRASTEST<1
QUIT 0
+7 ;
+8 SET IENS=LRASTEST_","_LRSP_","_LRODT_","
+9 ;
+10 SET ORIGPN=$$GET1^DIQ(69.03,IENS,"PROVIDER NARRATIVE")
+11 SET ORIGSN=$$GET1^DIQ(69.03,IENS,"SNOMED")
+12 SET ORIGICDP=$$GET1^DIQ(69.05,1_","_IENS,"ICD CODES")
+13 SET ORIGICDI=+$$GET1^DIQ(69.05,1_","_IENS,"ICD CODES","I")
+14 ;
+15 ; Q:$L(ORIGPN)<1!($L(ORIGSN)<1) 0 ; If no data to copy, quit
+16 ; IHS/MSC/MKK - LR*5.2*1035 -- If no data to copy, quit
IF $LENGTH(ORIGPN)<1&($LENGTH(ORIGSN)<1)
QUIT 0
+17 ;
+18 SET LRNEWTST=+$ORDER(^LRO(69,LRODT,1,LRSP,2,"B",LRTST,0))
+19 SET IENS=LRNEWTST_","_LRSP_","_LRODT_","
+20 ;
+21 ; S FDA(69.03,IENS,9999999.1)=ORIGPN
+22 ; S FDA(69.03,IENS,9999999.2)=ORIGSN
+23 ;
+24 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
+25 ; Data Can be either SNOMED or PROVIDER NARRATIVE or both
+26 IF $LENGTH(ORIGPN)
SET FDA(69.03,IENS,9999999.1)=ORIGPN
+27 IF $LENGTH(ORIGSN)
SET FDA(69.03,IENS,9999999.2)=ORIGSN
+28 ; ----- END IHS/MSC/MKK - LR*5.2*1035
+29 ;
+30 DO UPDATE^DIE("EKS","FDA",,"ERRS")
+31 ; I $D(ERRS) D ERRMSG^BLRSGNSP("ADDTLRAS: UPDATE^DIE","BLRSGNSU")
+32 ; IHS/MSC/MKK - LR*5.2*1035
IF $DATA(ERRS)
DO ERRMSG^BLRSGNS3("ADDTLRAS: 69.03 UPDATE^DIE","BLRSGNSU")
+33 ;
+34 KILL FDA,ERRS
+35 SET FDA(69.05,"?+1,"_IENS,.01)=ORIGICDP
+36 ; D UPDATE^DIE("EKS","FDA",,"ERRS")
+37 ; IHS/MSC/MKK - LR*5.2*1035 -- UPDATE IFF ORIGICDP variable has data
IF $LENGTH(ORIGICDP)
DO UPDATE^DIE("EKS","FDA",,"ERRS")
+38 ;
+39 ; If Error, try using ICD's IEN, if it exists
IF $DATA(ERRS)
IF ORIGICDI
Begin DoDot:1
+40 KILL FDA,ERRS
+41 SET FDA(69.05,"?+1,"_IENS,.01)=ORIGICDI
+42 DO UPDATE^DIE("S","FDA",,"ERRS")
End DoDot:1
+43 ;
+44 ; I $D(ERRS) D ERRMSG^BLRSGNSP("ADDTLRAS: UPDATE^DIE","BLRSGNSU")
+45 ; IHS/MSC/MKK - LR*5.2*1035
IF $DATA(ERRS)
DO ERRMSG^BLRSGNS3("ADDTLRAS: UPDATE^DIE","BLRSGNSU")
+46 QUIT 1
+47 ;
ACCESST(LRODT,LRSP,ORDTEST) ; EP - Determine the first test on an order with Accession data
+1 NEW IENS,ORDTEST,LRASTEST
+2 ;
+3 SET (ORDTEST,LRASTEST)=0
+4 FOR
SET ORDTEST=$ORDER(^LRO(69,LRODT,1,LRSP,2,ORDTEST))
IF ORDTEST<1!(LRASTEST)
QUIT
Begin DoDot:1
+5 SET IENS=ORDTEST_","_LRSP_","_LRODT
+6 ; LR*5.2*1035 - If no SNOMED, go to next test
IF $$GET1^DIQ(69.03,IENS,9999999.2)=""
QUIT
+7 ;
+8 IF +$$GET1^DIQ(69.03,IENS,"ACCESSION DATE","I")
SET LRASTEST=ORDTEST
End DoDot:1
+9 ;
+10 QUIT LRASTEST
+11 ;
+12 ; Called from ADDTST^BLRDIAG
ADDTORDN(LRODT,LRSP,LRTST) ; EP - Adding a test to an order?
+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 NEW (BAILOUT,DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,LRORD,LRODT,LRSP,LRTST,PNM,HRCN,U,XPARSYS,XQXFLG)
+3 ;
+4 DO HOME^%ZIS
+5 ;
+6 DO ENTRYAUD^BLRUTIL("ADDTORDN^BLRSGNSU 0.0")
+7 SET ORDERN=$$GET1^DIQ(69.01,LRSP_","_LRODT,"ORDER #")
+8 ;
+9 ; Skip if no Order #
IF +ORDERN<1
QUIT 0
+10 ;
+11 SET DIRZERO="SO^"
+12 SET (CNT,FOUNDIT,LR69ODT)=0
+13 FOR
SET LR69ODT=$ORDER(^LRO(69,"C",ORDERN,LR69ODT))
IF LR69ODT<1
QUIT
Begin DoDot:1
+14 SET LR69SP=0
+15 FOR
SET LR69SP=$ORDER(^LRO(69,"C",ORDERN,LR69ODT,LR69SP))
IF LR69SP<1
QUIT
Begin DoDot:2
+16 SET LROTST=0
+17 FOR
SET LROTST=$ORDER(^LRO(69,LR69ODT,1,LR69SP,2,LROTST))
IF LROTST<1
QUIT
Begin DoDot:3
+18 SET IENS=LROTST_","_LR69SP_","_LR69ODT
+19 SET F60DESC=$$GET1^DIQ(69.03,IENS,"TEST/PROCEDURE")
+20 SET PROVNARR=$$GET1^DIQ(69.03,IENS,"PROVIDER NARRATIVE")
+21 SET LRSNOMED=$$GET1^DIQ(69.03,IENS,"SNOMED")
+22 IF $LENGTH(PROVNARR)<1&($LENGTH(LRSNOMED)<1)
QUIT
+23 ;
+24 SET FOUNDIT=FOUNDIT+1
+25 SET CNT=CNT+1
+26 SET ORDTEST(CNT)=LROTST_","_LR69SP_","_LR69ODT
+27 SET DIRZERO=DIRZERO_CNT_":"_CNT_";"
+28 KILL STR
+29 SET STR=$JUSTIFY(CNT,2)
+30 SET $EXTRACT(STR,5)=$EXTRACT(F60DESC,1,18)
+31 SET $EXTRACT(STR,25)=LRSNOMED
+32 ; S $E(STR,41)=$E(PROVNARR,1,40)
+33 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
+34 SET $EXTRACT(STR,40)=$EXTRACT(PROVNARR,1,31)
+35 SET ICDCODE=$$GET1^DIQ(69.05,"1,"_IENS,.01)
+36 IF $LENGTH(ICDCODE)
SET $EXTRACT(STR,73)=ICDCODE
+37 ; ----- END IHS/MSC/MKK - LR*5.2*1035
+38 SET DIRZERO(CNT)=STR
End DoDot:3
End DoDot:2
End DoDot:1
+39 ;
+40 ; Skip -- No Data found on any of the other tests
IF FOUNDIT<1
QUIT 0
+41 ;
+42 SET CNT=CNT+1
+43 SET DIRZERO=DIRZERO_(CNT)_":NA"
+44 SET LASTCNT=CNT
+45 ;
+46 DO ^XBFMK
+47 SET DIR(0)=DIRZERO
+48 ; S DIR("L",1)=" TEST SNOMED PROVIDER NARRATIVE"
+49 ; S DIR("L",2)=" ------------------ ------------- ----------------------------------------"
+50 ; ----- BEGIN IHS/MSC/MKK LR*5.2*1035
+51 ; 12345678901234567890123456789012345678901234567890123456789012345678901234567890
+52 SET DIR("L",1)=" TEST SNOMED PROVIDER NARRATIVE ICD"
+53 SET DIR("L",2)=" ------------------ ------------- ------------------------------- --------"
+54 ; ----- END IHS/MSC/MKK LR*5.2*1035
+55 SET (CNT,MENUCNT)=0
+56 FOR
SET CNT=$ORDER(DIRZERO(CNT))
IF CNT<1
QUIT
Begin DoDot:1
+57 SET DIR("L",CNT+2)=$GET(DIRZERO(CNT))
+58 SET MENUCNT=CNT
End DoDot:1
+59 SET MENUCNT=MENUCNT+1
+60 SET DIR("L",MENUCNT+2)=" "
+61 SET MENUCNT=MENUCNT+1
+62 KILL STR
+63 SET STR=$JUSTIFY(LASTCNT,2)
+64 SET $EXTRACT(STR,5)="None of the Above"
+65 SET DIR("L",MENUCNT+2)=STR
+66 ;
+67 SET DIR("L")=""
+68 ; Change default prompt
SET DIR("A")="Select number"
+69 ;
+70 SET ADDTSTPN=$$GET1^DIQ(60,LRTST,"PRINT NAME")
+71 SET HEADER(1)="Lab Order Entry (#69)"
+72 SET HEADER(2)="Adding Test "_ADDTSTPN_" ["_LRTST_"] to Order # "_ORDERN
+73 SET HEADER(3)=$$CJ^XLFSTR("Selecting SNOMED",IOM)
+74 ;
+75 DO HEADERDT^BLRGMENU
+76 ;
+77 DO ^DIR
+78 ;
+79 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
+80 IF +$GET(ORDTEST(+Y))<1
Begin DoDot:1
+81 WRITE !!,?4,"No/Invalid/Quit Entry."
+82 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT 0
+83 ; ----- END IHS/MSC/MKK - LR*5.2*1035
+84 ;
+85 IF Y=LASTCNT
Begin DoDot:1
+86 WRITE !!,?4,"'None of the Above' Selected. Terminology Server will be called."
+87 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT 0
+88 ;
+89 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
+90 ; Moved this code above
+91 ; I +$G(ORDTEST(Y))<1 D Q 0
+92 ; . W !!,?4,"No/Invalid/Quit Entry."
+93 ; . D PRESSKEY^BLRGMENU(9)
+94 ; ----- END IHS/MSC/MKK - LR*5.2*1035
+95 ;
+96 SET IENS=$GET(ORDTEST(Y))
+97 ;
+98 SET ORIGPN=$$GET1^DIQ(69.03,IENS,"PROVIDER NARRATIVE")
+99 SET ORIGSN=$$GET1^DIQ(69.03,IENS,"SNOMED")
+100 SET ORIGICDP=$$GET1^DIQ(69.05,"1,"_IENS,"ICD CODES")
+101 ;
+102 ; If no data to copy, quit
IF $LENGTH(ORIGPN)<1!($LENGTH(ORIGSN)<1)
QUIT 0
+103 ;
+104 SET LRNEWTST=+$ORDER(^LRO(69,LRODT,1,LRSP,2,"B",LRTST,0))
+105 SET IENS=LRNEWTST_","_LRSP_","_LRODT_","
+106 ;
+107 SET FDA(69.03,IENS,9999999.1)=ORIGPN
+108 SET FDA(69.03,IENS,9999999.2)=ORIGSN
+109 IF $LENGTH(ORIGICDP)
SET FDA(69.05,"?+1,"_IENS,.01)=ORIGICDP
+110 DO UPDATE^DIE("EKS","FDA",,"ERRS")
+111 ;
+112 IF $DATA(ERRS)
Begin DoDot:1
+113 WRITE !!,?4,"Error trying to add data. See MailMan message."
+114 DO PRESSKEY^BLRGMENU(9)
+115 ; D ERRMSG^BLRSGNSP("ADDTLRAS: UPDATE^DIE","BLRSGNSU")
+116 ; IHS/MSC/MKK - LR*5.2*1035
DO ERRMSG^BLRSGNS3("ADDTLRAS: UPDATE^DIE","BLRSGNSU")
End DoDot:1
QUIT 0
+117 ;
+118 SET ADDTESTN=$$GET1^DIQ(60,LRTST,"NAME")
+119 WRITE !!,?4,"SNOMED ",ORIGSN," data added to test "_ADDTESTN_" ["_LRTST_"]."
+120 DO PRESSKEY^BLRGMENU(9)
+121 ;
+122 ; Successfully added entry
QUIT 1
+123 ;
+124 ; Subroutines moved from BLRSGNSY to here because BLRSGNSY became too large
CHKITOUT(DFN,LRODT) ; EP - User MUST select a diagnosis from list
+1 ; Check Problem List. If zero, use TEXTPOVI function
IF $$CHKPLIST(DFN,LRODT)<1
QUIT $$TEXTPOVI(DFN,LRODT)
+2 ;
+3 NEW (DFN,DEBUG,DILOCKTM,DISYS,DT,DTIME,DUZ,HRCN,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRODT,PNM,U,XPARSYS,XQXFLG)
+4 ;
+5 ; Use SNOMED codes & Provider Narrative
QUIT $$GETSNOPN(DFN,LRODT)
+6 ;
CHKPLIST(DFN,LRODT) ; EP - Check Problem List.
+1 NEW APISTR,ONLYONE,PROBICD,PROBCNT,PROBIEN,PSTATUS
+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 SET CONCID=$$GET1^DIQ(9000011,PROBIEN,"SNOMED CT CONCEPT CODE","I")
+6 IF CONCID<1
QUIT
+7 ;
+8 SET PSTATUS=$$GET1^DIQ(9000011,PROBIEN,"STATUS","I")
+9 ; If problem's status is INACTIVE or DELETED, skip
IF PSTATUS="I"!(PSTATUS="D")
QUIT
+10 ;
+11 ; Make sure current codes as of Order's date are returned
SET $PIECE(CONCID,"^",3)=LRODT
+12 ; S APISTR=$$CONC^BSTSAPI(CONCID) ; Return Data from Terminology Server
+13 ; Search for Data from Terminology Server's local cache first -- LR*5.2*1034
SET APISTR=$$CONC^BSTSAPI(CONCID_"^^^1")
+14 ; If no local cache data, return Data from Terminology Server -- LR*5.2*1034
IF $LENGTH($TRANSLATE(APISTR,"^"))<1
SET APISTR=$$CONC^BSTSAPI(CONCID)
+15 SET PROBICD=$PIECE($PIECE(APISTR,"^",5),";")
+16 ; Q:$E(PROBICD)="Z" ; Skip if ICD code begins with "Z"
+17 ; Q:PROBICD=799.9 ; Skip if ICD code is a place holder
+18 ; Q:PROBICD=.9999 ; Skip if ICD code is invalid
+19 ;
+20 SET PROBCNT=PROBCNT+1
End DoDot:1
+21 ;
+22 QUIT PROBCNT
+23 ;
+24 ; The following code reads the patient's entries in the PROBLEM file, uses the SNOMED Code
+25 ; and creates the necessary string for ListMan.
GETSNOPN(DFN,LRODT) ; EP - SNOMED Selections
+1 NEW APISTR,ENTERDT,ICDCODE,ICDDESC,ICDPROB,ICDSTR,IEN,IN,LASTMODD,PROBICD,PROBCNT,PROBIEN,PROBLEMS,SNOMED,SNOMEDSC,VARS,VARSDESC
+2 ;
+3 SET PROBIEN="AAA"
SET OUT="VARSDESC"
SET CNT=0
+4 FOR
SET PROBIEN=$ORDER(^AUPNPROB("AC",DFN,PROBIEN),-1)
IF PROBIEN<1
QUIT
Begin DoDot:1
+5 SET CONCID=$$GET1^DIQ(9000011,PROBIEN,"SNOMED CT CONCEPT CODE","I")
+6 IF CONCID<1
QUIT
+7 ;
+8 SET PSTATUS=$$GET1^DIQ(9000011,PROBIEN,"STATUS","I")
+9 ; If problem's status is INACTIVE or DELETED, skip
IF PSTATUS="I"!(PSTATUS="D")
QUIT
+10 ;
+11 ; Make sure current codes as of Order's date are returned
SET $PIECE(CONCID,"^",3)=LRODT
+12 ; S APISTR=$$CONC^BSTSAPI(CONCID) ; Return Data from Terminology Server
+13 ; Search for Data from Terminology Server's local cache first -- LR*5.2*1034
SET APISTR=$$CONC^BSTSAPI(CONCID_"^^^1")
+14 ; If no local cache data, return Data from Terminology Server -- LR*5.2*1034
IF $LENGTH($TRANSLATE(APISTR,"^"))<1
SET APISTR=$$CONC^BSTSAPI(CONCID)
+15 SET ICDCODE=$PIECE($PIECE(APISTR,"^",5),";")
+16 ; Q:$E(ICDCODE)="Z" ; Skip if ICD code begins with "Z"
+17 ; Q:ICDCODE=799.9 ; Skip if ICD code is a place holder
+18 ; Q:ICDCODE=.9999 ; Skip if ICD code is invalid
+19 ;
+20 SET SNOMED=$PIECE(APISTR,"^",3)
+21 SET SNOMEDSC=$PIECE(APISTR,"^",4)
+22 ;
+23 SET CNT=CNT+1
+24 SET VARS(CNT,"PRB","DSC")=SNOMED
+25 SET VARS(CNT,"PRB","TRM")=SNOMEDSC
+26 SET VARS(CNT,"ICD",1,"COD")=ICDCODE
End DoDot:1
+27 ;
+28 ; S ^TMP("BLR SNOMED GET",$J,"HDR")="You MUST Select an appropriate SNOMED code from the Patient's Problem List."
+29 ; IHS/MSC/MKK - LR*5.2*1035
SET ^TMP("BLR SNOMED GET",$JOB,"HDR")="Select an appropriate SNOMED code from the Patient's "_CNT_" Problems."
+30 QUIT $$LISTMSEL^BLRSGNSY()
+31 ;
TEXTPOVI(DFN,LRODT) ; EP - No Entries in PROBLEM file; use Text & BSTS Database
+1 NEW (DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,HRCN,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRODT,PNM,U,XPARSYS,XQXFLG)
+2 ;
+3 ; Do "banner" like notice to user
IF +$GET(DFN)
Begin DoDot:1
+4 WRITE !!,?4,$TRANSLATE($JUSTIFY("",67)," ","*"),!
+5 WRITE ?4,"** Patient has no entries in the PROBLEM File with SNOMED codes. **",!
+6 WRITE ?4,$TRANSLATE($JUSTIFY("",67)," ","*"),!!
End DoDot:1
+7 ;
+8 DO GETDIAG(LRODT)
+9 IF +$GET(BAILOUT)
QUIT "BAILOUT"
+10 ;
+11 SET ^TMP("BLR SNOMED GET",$JOB,"HDR")="You MUST Select an appropriate SNOMED code."
+12 QUIT $$LISTMSEL^BLRSGNSY()
+13 ;
GETDIAG(LRODT) ; EP - Get a diagnosis.
+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 PROVNARR^BLRSGNSY
+9 DO ^XBFMK
+10 SET DIR(0)="F"
+11 SET DIR("A")="Enter Clinical Indication (Free Text)"
+12 ; IHS/MSC/MKK - LR*5.2*1035 - Wait 30 Minutes
SET DIR("T")=1800
+13 DO ^DIR
+14 ; Trick to exit
IF $GET(X)="^^^^^"
SET Y=99999999
QUIT
+15 ;
+16 IF $LENGTH(X)<1
Begin DoDot:2
+17 WRITE !!,?4,"Invalid. Must Enter a Clinical Indication.",!
+18 DO PRESSKEY^BLRGMENU(9)
+19 SET Y=0
End DoDot:2
QUIT
+20 IF +$GET(DUOUT)
Begin DoDot:2
+21 DO ^XBFMK
+22 SET DIR(0)="Y"
+23 ; S DIR("A")="Delete Order (Y/N)"
+24 SET DIR("A")="Delete "_$SELECT(ONETEST:"Test",1:"Order")_" (Y/N)"
+25 SET DIR("B")="NO"
+26 ; IHS/MSC/MKK - LR*5.2*1035 - Wait 30 Minutes
SET DIR("T")=1800
+27 DO ^DIR
+28 IF Y=1
SET BAILOUT=1
SET Y=0
+29 IF '$TEST
SET Y=0
End DoDot:2
QUIT
+30 KILL OUT
+31 SET OUT="VARS"
SET IN=$GET(X)_"^S"
+32 ; Make certain current codes returned
SET $PIECE(IN,"^",5)=LRODT
+33 SET $PIECE(IN,"^",6)=200
SET $PIECE(IN,"^",8)=1
+34 SET Y=$$SEARCH^BSTSAPI(OUT,IN)
+35 DO ADDICD9
+36 IF Y<1
WRITE !!,?9,"No entries found in the IHS STANDARD TERMINOLOGY database. Try Again."
End DoDot:1
+37 ;
+38 IF BAILOUT
DO GETRID^BLRSGNSP($GET(^TMP("BLRDIAG",$JOB,"ORDER")))
+39 IF Y=99999999
SET BAILOUT=1
+40 ;
+41 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
+42 SET VARSCNT=$ORDER(VARS("A"),-1)
+43 SET ^TMP("BLR SNOMED GET",$JOB,"HDR")="Select an appropriate SNOMED code from the "_VARSCNT_" retrieved."
+44 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
+45 ;
+46 QUIT
+47 ;
ADDICD9 ; EP - Adds ICD9 codes to VARS array
+1 ; IHS/MSC/MKK - LR*5.2*1035 -- Do *NOT* add the ICD9 codes
QUIT
+2 ;
+3 NEW WOT,ICD10DT,ICD10PTR,TODAY
+4 ;
+5 SET ICD10PTR=+$$FIND1^DIC(80.4,,,"ICD-10-CM")
+6 SET ICD10DT=+$PIECE($$GET1^DIQ(80.4,ICD10PTR,"IMPLEMENTATION DATE","I"),".")
+7 ; If no ICD10DT, hard set to 10/1/2015.
IF ICD10DT<1
SET ICD10DT=3151001
+8 SET TODAY=$$DT^XLFDT
+9 ;
+10 ; Q:TODAY'<ICD10DT ; Skip if after ICD-10 "start date" - IHS/MSC/MKK - LR*5.2*1034
+11 ;
+12 SET WOT=0
+13 FOR
SET WOT=$ORDER(VARS(WOT))
IF WOT<1
QUIT
Begin DoDot:1
+14 ; If ICD code, just return
IF $DATA(VARS(WOT,"ICD"))
QUIT
+15 ;
+16 SET VARS(WOT,"ICD",1,"COD")=$SELECT(TODAY<ICD10DT:".9999",1:"ZZZ.999")
+17 SET VARS(WOT,"ICD",1,"TYP")=$SELECT(TODAY<ICD10DT:"ICD",1:"10D")
End DoDot:1
+18 ;
+19 QUIT
