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

BLRSGNSU.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. EEP ; Ersatz EP
  1.  D EEP^BLRGMENU
  1.  Q
  1.  ;
  1.  ; Called from ADDTST^BLRDIAG
  1. CHKORDAC(LRODT,ORDIEN,TST) ; EP - Adding a test?
  1.  D ENTRYAUD^BLRUTIL("CHKORDAC^BLRSGNSU 0.0")
  1.  ;
  1.  Q:$$ADDTLRAS(LRODT,ORDIEN,TST) 1
  1.  ;
  1.  Q:$$ACCESST(LRODT,ORDIEN,TST) 0       ; IHS/MSC/MKK - LR*5.2*1034 - Accession on Order, exit
  1.  ;
  1.  Q:$$ADDTORDN(LRODT,ORDIEN,TST) 1      ; IHS/MSC/MKK - LR*5.2*1034 - Only orders
  1.  ;
  1.  Q 0
  1.  ;
  1. 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)
  1.  ;
  1.  D ENTRYAUD^BLRUTIL("ADDTLRAS^BLRSGNSU 0.0")
  1.  ;
  1.  S LRASTEST=$$ACCESST(LRODT,LRSP,LRTST)    ; Get first test on order with Accession data
  1.  Q:LRASTEST<1 0
  1.  ;
  1.  S IENS=LRASTEST_","_LRSP_","_LRODT_","
  1.  ;
  1.  S ORIGPN=$$GET1^DIQ(69.03,IENS,"PROVIDER NARRATIVE")
  1.  S ORIGSN=$$GET1^DIQ(69.03,IENS,"SNOMED")
  1.  S ORIGICDP=$$GET1^DIQ(69.05,1_","_IENS,"ICD CODES")
  1.  S ORIGICDI=+$$GET1^DIQ(69.05,1_","_IENS,"ICD CODES","I")
  1.  ;
  1.  ; Q:$L(ORIGPN)<1!($L(ORIGSN)<1) 0    ; If no data to copy, quit
  1.  Q:$L(ORIGPN)<1&($L(ORIGSN)<1) 0  ; IHS/MSC/MKK - LR*5.2*1035 -- If no data to copy, quit
  1.  ;
  1.  S LRNEWTST=+$O(^LRO(69,LRODT,1,LRSP,2,"B",LRTST,0))
  1.  S IENS=LRNEWTST_","_LRSP_","_LRODT_","
  1.  ;
  1.  ; S FDA(69.03,IENS,9999999.1)=ORIGPN
  1.  ; S FDA(69.03,IENS,9999999.2)=ORIGSN
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
  1.  ; Data Can be either SNOMED or PROVIDER NARRATIVE or both
  1.  S:$L(ORIGPN) FDA(69.03,IENS,9999999.1)=ORIGPN
  1.  S:$L(ORIGSN) FDA(69.03,IENS,9999999.2)=ORIGSN
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1035
  1.  ;
  1.  D UPDATE^DIE("EKS","FDA",,"ERRS")
  1.  ; I $D(ERRS) D ERRMSG^BLRSGNSP("ADDTLRAS: UPDATE^DIE","BLRSGNSU")
  1.  I $D(ERRS) D ERRMSG^BLRSGNS3("ADDTLRAS: 69.03 UPDATE^DIE","BLRSGNSU")    ; IHS/MSC/MKK - LR*5.2*1035
  1.  ;
  1.  K FDA,ERRS
  1.  S FDA(69.05,"?+1,"_IENS,.01)=ORIGICDP
  1.  ; D UPDATE^DIE("EKS","FDA",,"ERRS")
  1.  D:$L(ORIGICDP) UPDATE^DIE("EKS","FDA",,"ERRS")  ; IHS/MSC/MKK - LR*5.2*1035 -- UPDATE IFF ORIGICDP variable has data
  1.  ;
  1.  I $D(ERRS),ORIGICDI D  ; If Error, try using ICD's IEN, if it exists
  1.  . K FDA,ERRS
  1.  . S FDA(69.05,"?+1,"_IENS,.01)=ORIGICDI
  1.  . D UPDATE^DIE("S","FDA",,"ERRS")
  1.  ;
  1.  ; I $D(ERRS) D ERRMSG^BLRSGNSP("ADDTLRAS: UPDATE^DIE","BLRSGNSU")
  1.  I $D(ERRS) D ERRMSG^BLRSGNS3("ADDTLRAS: UPDATE^DIE","BLRSGNSU")     ; IHS/MSC/MKK - LR*5.2*1035
  1.  Q 1
  1.  ;
  1. ACCESST(LRODT,LRSP,ORDTEST) ; EP - Determine the first test on an order with Accession data
  1.  NEW IENS,ORDTEST,LRASTEST
  1.  ;
  1.  S (ORDTEST,LRASTEST)=0
  1.  F  S ORDTEST=$O(^LRO(69,LRODT,1,LRSP,2,ORDTEST))  Q:ORDTEST<1!(LRASTEST)  D
  1.  . S IENS=ORDTEST_","_LRSP_","_LRODT
  1.  . Q:$$GET1^DIQ(69.03,IENS,9999999.2)=""    ; LR*5.2*1035 - If no SNOMED, go to next test
  1.  . ;
  1.  . S:+$$GET1^DIQ(69.03,IENS,"ACCESSION DATE","I") LRASTEST=ORDTEST
  1.  ;
  1.  Q LRASTEST
  1.  ;
  1.  ; Called from ADDTST^BLRDIAG
  1. 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)
  1.  NEW (BAILOUT,DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,LRORD,LRODT,LRSP,LRTST,PNM,HRCN,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D HOME^%ZIS
  1.  ;
  1.  D ENTRYAUD^BLRUTIL("ADDTORDN^BLRSGNSU 0.0")
  1.  S ORDERN=$$GET1^DIQ(69.01,LRSP_","_LRODT,"ORDER #")
  1.  ;
  1.  Q:+ORDERN<1 0  ; Skip if no Order #
  1.  ;
  1.  S DIRZERO="SO^"
  1.  S (CNT,FOUNDIT,LR69ODT)=0
  1.  F  S LR69ODT=$O(^LRO(69,"C",ORDERN,LR69ODT))  Q:LR69ODT<1  D
  1.  . S LR69SP=0
  1.  . F  S LR69SP=$O(^LRO(69,"C",ORDERN,LR69ODT,LR69SP))  Q:LR69SP<1  D
  1.  .. S LROTST=0
  1.  .. F  S LROTST=$O(^LRO(69,LR69ODT,1,LR69SP,2,LROTST))  Q:LROTST<1  D
  1.  ... S IENS=LROTST_","_LR69SP_","_LR69ODT
  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.  ... ;
  1.  ... S FOUNDIT=FOUNDIT+1
  1.  ... S CNT=CNT+1
  1.  ... S ORDTEST(CNT)=LROTST_","_LR69SP_","_LR69ODT
  1.  ... S DIRZERO=DIRZERO_CNT_":"_CNT_";"
  1.  ... K STR
  1.  ... S STR=$J(CNT,2)
  1.  ... S $E(STR,5)=$E(F60DESC,1,18)
  1.  ... S $E(STR,25)=LRSNOMED
  1.  ... ; S $E(STR,41)=$E(PROVNARR,1,40)
  1.  ... ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
  1.  ... S $E(STR,40)=$E(PROVNARR,1,31)
  1.  ... S ICDCODE=$$GET1^DIQ(69.05,"1,"_IENS,.01)
  1.  ... S:$L(ICDCODE) $E(STR,73)=ICDCODE
  1.  ... ; ----- END IHS/MSC/MKK - LR*5.2*1035
  1.  ... S DIRZERO(CNT)=STR
  1.  ;
  1.  Q:FOUNDIT<1 0  ; Skip -- No Data found on any of the other tests
  1.  ;
  1.  S CNT=CNT+1
  1.  S DIRZERO=DIRZERO_(CNT)_":NA"
  1.  S LASTCNT=CNT
  1.  ;
  1.  D ^XBFMK
  1.  S DIR(0)=DIRZERO
  1.  ; S DIR("L",1)="    TEST                SNOMED          PROVIDER NARRATIVE"
  1.  ; S DIR("L",2)="    ------------------  -------------   ----------------------------------------"
  1.  ; ----- BEGIN IHS/MSC/MKK LR*5.2*1035
  1.  ;             12345678901234567890123456789012345678901234567890123456789012345678901234567890
  1.  S DIR("L",1)="    TEST                SNOMED         PROVIDER NARRATIVE               ICD"
  1.  S DIR("L",2)="    ------------------  -------------  -------------------------------  --------"
  1.  ; ----- END IHS/MSC/MKK LR*5.2*1035
  1.  S (CNT,MENUCNT)=0
  1.  F  S CNT=$O(DIRZERO(CNT))  Q:CNT<1  D
  1.  . S DIR("L",CNT+2)=$G(DIRZERO(CNT))
  1.  . S MENUCNT=CNT
  1.  S MENUCNT=MENUCNT+1
  1.  S DIR("L",MENUCNT+2)=" "
  1.  S MENUCNT=MENUCNT+1
  1.  K STR
  1.  S STR=$J(LASTCNT,2)
  1.  S $E(STR,5)="None of the Above"
  1.  S DIR("L",MENUCNT+2)=STR
  1.  ;
  1.  S DIR("L")=""
  1.  S DIR("A")="Select number"    ; Change default prompt
  1.  ;
  1.  S ADDTSTPN=$$GET1^DIQ(60,LRTST,"PRINT NAME")
  1.  S HEADER(1)="Lab Order Entry (#69)"
  1.  S HEADER(2)="Adding Test "_ADDTSTPN_" ["_LRTST_"] to Order # "_ORDERN
  1.  S HEADER(3)=$$CJ^XLFSTR("Selecting SNOMED",IOM)
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  D ^DIR
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
  1.  I +$G(ORDTEST(+Y))<1 D  Q 0
  1.  . W !!,?4,"No/Invalid/Quit Entry."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1035
  1.  ;
  1.  I Y=LASTCNT D  Q 0
  1.  . W !!,?4,"'None of the Above' Selected.  Terminology Server will be called."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
  1.  ; Moved this code above
  1.  ; I +$G(ORDTEST(Y))<1 D  Q 0
  1.  ; . W !!,?4,"No/Invalid/Quit Entry."
  1.  ; . D PRESSKEY^BLRGMENU(9)
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1035
  1.  ;
  1.  S IENS=$G(ORDTEST(Y))
  1.  ;
  1.  S ORIGPN=$$GET1^DIQ(69.03,IENS,"PROVIDER NARRATIVE")
  1.  S ORIGSN=$$GET1^DIQ(69.03,IENS,"SNOMED")
  1.  S ORIGICDP=$$GET1^DIQ(69.05,"1,"_IENS,"ICD CODES")
  1.  ;
  1.  Q:$L(ORIGPN)<1!($L(ORIGSN)<1) 0    ; If no data to copy, quit
  1.  ;
  1.  S LRNEWTST=+$O(^LRO(69,LRODT,1,LRSP,2,"B",LRTST,0))
  1.  S IENS=LRNEWTST_","_LRSP_","_LRODT_","
  1.  ;
  1.  S FDA(69.03,IENS,9999999.1)=ORIGPN
  1.  S FDA(69.03,IENS,9999999.2)=ORIGSN
  1.  S:$L(ORIGICDP) FDA(69.05,"?+1,"_IENS,.01)=ORIGICDP
  1.  D UPDATE^DIE("EKS","FDA",,"ERRS")
  1.  ;
  1.  I $D(ERRS) D  Q 0
  1.  . W !!,?4,"Error trying to add data.  See MailMan message."
  1.  . D PRESSKEY^BLRGMENU(9)
  1.  . ; D ERRMSG^BLRSGNSP("ADDTLRAS: UPDATE^DIE","BLRSGNSU")
  1.  . D ERRMSG^BLRSGNS3("ADDTLRAS: UPDATE^DIE","BLRSGNSU")    ; IHS/MSC/MKK - LR*5.2*1035
  1.  ;
  1.  S ADDTESTN=$$GET1^DIQ(60,LRTST,"NAME")
  1.  W !!,?4,"SNOMED ",ORIGSN," data added to test "_ADDTESTN_" ["_LRTST_"]."
  1.  D PRESSKEY^BLRGMENU(9)
  1.  ;
  1.  Q 1  ; Successfully added entry
  1.  ;
  1.  ; Subroutines moved from BLRSGNSY to here because BLRSGNSY became too large
  1. CHKITOUT(DFN,LRODT) ; EP - User MUST select a diagnosis from list
  1.  Q:$$CHKPLIST(DFN,LRODT)<1 $$TEXTPOVI(DFN,LRODT) ; Check Problem List.  If zero, use TEXTPOVI function
  1.  ;
  1.  NEW (DFN,DEBUG,DILOCKTM,DISYS,DT,DTIME,DUZ,HRCN,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRODT,PNM,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q $$GETSNOPN(DFN,LRODT)     ; Use SNOMED codes & Provider Narrative
  1.  ;
  1. CHKPLIST(DFN,LRODT) ; EP - Check Problem List.
  1.  NEW APISTR,ONLYONE,PROBICD,PROBCNT,PROBIEN,PSTATUS
  1.  ;
  1.  S PROBCNT=0,PROBICD="",PROBIEN="AAA"
  1.  F  S PROBIEN=$O(^AUPNPROB("AC",DFN,PROBIEN),-1)  Q:PROBIEN<1  D
  1.  . S CONCID=$$GET1^DIQ(9000011,PROBIEN,"SNOMED CT CONCEPT CODE","I")
  1.  . Q:CONCID<1
  1.  . ;
  1.  . S PSTATUS=$$GET1^DIQ(9000011,PROBIEN,"STATUS","I")
  1.  . Q:PSTATUS="I"!(PSTATUS="D")    ; If problem's status is INACTIVE or DELETED, skip
  1.  . ;
  1.  . S $P(CONCID,"^",3)=LRODT            ; Make sure current codes as of Order's date are returned
  1.  . ; S APISTR=$$CONC^BSTSAPI(CONCID)     ; Return Data from Terminology Server
  1.  . S APISTR=$$CONC^BSTSAPI(CONCID_"^^^1")                  ; Search for Data from Terminology Server's local cache first -- LR*5.2*1034
  1.  . S:$L($TR(APISTR,"^"))<1 APISTR=$$CONC^BSTSAPI(CONCID)   ; If no local cache data, return Data from Terminology Server -- LR*5.2*1034
  1.  . S PROBICD=$P($P(APISTR,"^",5),";")
  1.  . ; Q:$E(PROBICD)="Z"                   ; Skip if ICD code begins with "Z"
  1.  . ; Q:PROBICD=799.9                     ; Skip if ICD code is a place holder
  1.  . ; Q:PROBICD=.9999                     ; Skip if ICD code is invalid
  1.  . ;
  1.  . S PROBCNT=PROBCNT+1
  1.  ;
  1.  Q PROBCNT
  1.  ;
  1.  ; The following code reads the patient's entries in the PROBLEM file, uses the SNOMED Code
  1.  ; and creates the necessary string for ListMan.
  1. 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
  1.  ;
  1.  S PROBIEN="AAA",OUT="VARSDESC",CNT=0
  1.  F  S PROBIEN=$O(^AUPNPROB("AC",DFN,PROBIEN),-1)  Q:PROBIEN<1  D
  1.  . S CONCID=$$GET1^DIQ(9000011,PROBIEN,"SNOMED CT CONCEPT CODE","I")
  1.  . Q:CONCID<1
  1.  . ;
  1.  . S PSTATUS=$$GET1^DIQ(9000011,PROBIEN,"STATUS","I")
  1.  . Q:PSTATUS="I"!(PSTATUS="D")    ; If problem's status is INACTIVE or DELETED, skip
  1.  . ;
  1.  . S $P(CONCID,"^",3)=LRODT            ; Make sure current codes as of Order's date are returned
  1.  . ; S APISTR=$$CONC^BSTSAPI(CONCID)     ; Return Data from Terminology Server
  1.  . S APISTR=$$CONC^BSTSAPI(CONCID_"^^^1")                  ; Search for Data from Terminology Server's local cache first -- LR*5.2*1034
  1.  . S:$L($TR(APISTR,"^"))<1 APISTR=$$CONC^BSTSAPI(CONCID)   ; If no local cache data, return Data from Terminology Server -- LR*5.2*1034
  1.  . S ICDCODE=$P($P(APISTR,"^",5),";")
  1.  . ; Q:$E(ICDCODE)="Z"                   ; Skip if ICD code begins with "Z"
  1.  . ; Q:ICDCODE=799.9                     ; Skip if ICD code is a place holder
  1.  . ; Q:ICDCODE=.9999                     ; Skip if ICD code is invalid
  1.  . ;
  1.  . S SNOMED=$P(APISTR,"^",3)
  1.  . S SNOMEDSC=$P(APISTR,"^",4)
  1.  . ;
  1.  . S CNT=CNT+1
  1.  . S VARS(CNT,"PRB","DSC")=SNOMED
  1.  . S VARS(CNT,"PRB","TRM")=SNOMEDSC
  1.  . S VARS(CNT,"ICD",1,"COD")=ICDCODE
  1.  ;
  1.  ; S ^TMP("BLR SNOMED GET",$J,"HDR")="You MUST Select an appropriate SNOMED code from the Patient's Problem List."
  1.  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
  1.  Q $$LISTMSEL^BLRSGNSY()
  1.  ;
  1. 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)
  1.  ;
  1.  I +$G(DFN) D  ; Do "banner" like notice to user
  1.  . W !!,?4,$TR($J("",67)," ","*"),!
  1.  . W ?4,"** Patient has no entries in the PROBLEM File with SNOMED codes. **",!
  1.  . W ?4,$TR($J("",67)," ","*"),!!
  1.  ;
  1.  D GETDIAG(LRODT)
  1.  Q:+$G(BAILOUT) "BAILOUT"
  1.  ;
  1.  S ^TMP("BLR SNOMED GET",$J,"HDR")="You MUST Select an appropriate SNOMED code."
  1.  Q $$LISTMSEL^BLRSGNSY()
  1.  ;
  1. GETDIAG(LRODT) ; EP - Get a diagnosis.
  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 PROVNARR^BLRSGNSY
  1.  . D ^XBFMK
  1.  . S DIR(0)="F"
  1.  . S DIR("A")="Enter Clinical Indication (Free Text)"
  1.  . S DIR("T")=1800      ; IHS/MSC/MKK - LR*5.2*1035 - Wait 30 Minutes
  1.  . D ^DIR
  1.  . I $G(X)="^^^^^"  S Y=99999999  Q    ; Trick to exit
  1.  . ;
  1.  . I $L(X)<1 D  Q
  1.  .. W !!,?4,"Invalid.  Must Enter a Clinical Indication.",!
  1.  .. D PRESSKEY^BLRGMENU(9)
  1.  .. S Y=0
  1.  . I +$G(DUOUT) D  Q
  1.  .. D ^XBFMK
  1.  .. S DIR(0)="Y"
  1.  .. ; S DIR("A")="Delete Order (Y/N)"
  1.  .. S DIR("A")="Delete "_$S(ONETEST:"Test",1:"Order")_" (Y/N)"
  1.  .. S DIR("B")="NO"
  1.  .. S DIR("T")=1800      ; IHS/MSC/MKK - LR*5.2*1035 - Wait 30 Minutes
  1.  .. D ^DIR
  1.  .. I Y=1 S BAILOUT=1,Y=0
  1.  .. E  S Y=0
  1.  . K OUT
  1.  . S OUT="VARS",IN=$G(X)_"^S"
  1.  . S $P(IN,"^",5)=LRODT      ; Make certain current codes returned
  1.  . S $P(IN,"^",6)=200,$P(IN,"^",8)=1
  1.  . S Y=$$SEARCH^BSTSAPI(OUT,IN)
  1.  . D ADDICD9
  1.  . I Y<1 W !!,?9,"No entries found in the IHS STANDARD TERMINOLOGY database.  Try Again."
  1.  ;
  1.  D:BAILOUT GETRID^BLRSGNSP($G(^TMP("BLRDIAG",$J,"ORDER")))
  1.  S:Y=99999999 BAILOUT=1
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
  1.  S VARSCNT=$O(VARS("A"),-1)
  1.  S ^TMP("BLR SNOMED GET",$J,"HDR")="Select an appropriate SNOMED code from the "_VARSCNT_" retrieved."
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1035
  1.  ;
  1.  Q
  1.  ;
  1. ADDICD9 ; EP - Adds ICD9 codes to VARS array
  1.  Q  ; IHS/MSC/MKK - LR*5.2*1035 -- Do *NOT* add the ICD9 codes
  1.  ;
  1.  NEW WOT,ICD10DT,ICD10PTR,TODAY
  1.  ;
  1.  S ICD10PTR=+$$FIND1^DIC(80.4,,,"ICD-10-CM")
  1.  S ICD10DT=+$P($$GET1^DIQ(80.4,ICD10PTR,"IMPLEMENTATION DATE","I"),".")
  1.  S:ICD10DT<1 ICD10DT=3151001   ; If no ICD10DT, hard set to 10/1/2015.
  1.  S TODAY=$$DT^XLFDT
  1.  ;
  1.  ; Q:TODAY'<ICD10DT       ; Skip if after ICD-10 "start date" - IHS/MSC/MKK - LR*5.2*1034
  1.  ;
  1.  S WOT=0
  1.  F  S WOT=$O(VARS(WOT))  Q:WOT<1  D
  1.  . Q:$D(VARS(WOT,"ICD"))  ; If ICD code, just return
  1.  . ;
  1.  . S VARS(WOT,"ICD",1,"COD")=$S(TODAY<ICD10DT:".9999",1:"ZZZ.999")
  1.  . S VARS(WOT,"ICD",1,"TYP")=$S(TODAY<ICD10DT:"ICD",1:"10D")
  1.  ;
  1.  Q