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

BLRSGNSD.m

Go to the documentation of this file. 
  1. BLRSGNSD ; IHS/OIT/MKK - IHS Lab SiGN or Symptom Debug ; 17-Oct-2014 09:22 ; MKK
  1.  ;;5.2;IHS LABORATORY;**1033,1034**;NOV 1, 1997;Build 88
  1.  ;
  1.  ; This routine created to debug the BLRSGNSY routine.
  1.  ;
  1. EEP ; Ersatz EP
  1.  D EEP^BLRGMENU
  1.  Q
  1.  ;
  1. PEP ; EP
  1. EP ; EP
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  ;
  1.  D ADDTMENU^BLRGMENU("DISPPRBL^BLRSGNSD","Select Patient & Then Select 'Clinical Indication' from List")
  1.  D ADDTMENU^BLRGMENU("FINDSOME^BLRSGNSD","Find Patients With Problem List & Lab Orders")
  1.  D ADDTMENU^BLRGMENU("FINDNOLA^BLRSGNSD","Find Patients With Problem List & No Lab Orders")
  1.  D ADDTMENU^BLRGMENU("FINDNONE^BLRSGNSD","Find Patients With Lab orders But No Problem File Entries")
  1.  D ADDTMENU^BLRGMENU("SHOAPROB^BLRSGNSD","Select Patient and Display ALL entries in Problem File")
  1.  D ADDTMENU^BLRGMENU("RESETOFD^BLRSGNS2","Reset SNOMED/Descrip in File 69 Given Order #")
  1.  D ADDTMENU^BLRGMENU("NEWPROBS^BLRSGNS2","List the Latest Entries in the Problem file")
  1.  D ADDTMENU^BLRGMENU("JUSTVALS^BLRSGNS2","Test the Terminology Server")
  1.  D ADDTMENU^BLRGMENU("JUSTICDS^BLRSGNS2","Test the Terminology Server - Valid ICD Only")
  1.  D ADDTMENU^BLRGMENU("ERRMSGRP^BLRSGNS2","Report on ERRMSG^BLRSGNP Messages")
  1.  ;
  1.  ; Main Menu driver
  1.  D MENUDRFM^BLRGMENU("RPMS Lab Meaningful Use Stage 2","Clnical Indication Debug Routines")
  1.  Q
  1.  ;
  1. DISPPRBL ; EP - Enter Patient And Display Problem List
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  ;
  1.  S HEADER(1)="RPMS Lab Meaningful Use Stage 2"
  1.  S HEADER(2)="Select 'Clinical Indication' Debug"
  1.  ;
  1.  ; Get Patient
  1.  S HEADER(3)=$$CJ^XLFSTR("Select Patient",IOM)
  1.  D HEADERDT^BLRGMENU
  1.  S DFN=0
  1.  F  Q:DFN!(DFN<0)  D
  1.  . S LRLOOKUP=1
  1.  . K DIC,LRDPAF,%DT("B") S DIC(0)="A"
  1.  . D ^LRDPA
  1.  ;
  1.  Q:DFN<0   ; Skip if no patient selected
  1.  ;
  1.  K HEADER(3)
  1.  S HEADER(3)=$$CJ^XLFSTR("Patient Name:"_$P($G(^DPT(DFN,0)),"^"),IOM)
  1.  D HEADERDT^BLRGMENU
  1.  ;
  1.  ; S SNOMEDS=$$CHKITOUT^BLRSGNSY(DFN)
  1.  S SNOMEDS=$$CHKITOUT^BLRSGNSU(DFN,$$DT^XLFDT)   ; IHS/MSC/MKK - LR*5.2*1034
  1.  ;
  1.  W !!,?4,"SNOMED String:",SNOMEDS,!!
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. SHOWSELP() ; EP - Select Patient
  1.  ; Select Patient
  1.  S HEADER(1)="RPMS Lab Meaningful Use Stage 2"
  1.  S HEADER(2)="ALL Problems from PROBLEM (#9000011) File"
  1.  S HEADER(3)=$$CJ^XLFSTR("Select Patient",IOM)
  1.  ;
  1.  S DFN=0
  1.  F  Q:DFN!(DFN<0)  D
  1.  . D HEADERDT^BLRGMENU
  1.  . S LRLOOKUP=1
  1.  . K DIC,LRDPAF,%DT("B") S DIC(0)="A"
  1.  . D ^LRDPA
  1.  ;
  1.  Q:DFN<0 "Q"
  1.  ;
  1.  Q "OK"
  1.  ;
  1. SHOWPEND ; EP - Ending
  1.  W:CNT<1 !!,?4,"No Active entries on Problem List for the patient."
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. FINDSOME ; EP - Find some patients that have a problem list AND lab orders
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D FINDSOMI
  1.  ;
  1.  F  S DFN=$O(^AUPNPROB("AC",DFN))  Q:DFN<1!(CNT>MAX)  D FINDSOML
  1.  ;
  1.  W !!,?4,DFNCNT," Patients in Problems File."
  1.  W !!,?9,$S(DFNORDS:DFNORDS,1:"No")," Patients with Orders."
  1.  W !!,?14,$S(CNT:CNT,1:"No")," Patients with Problems in the past year."
  1.  D PRESSKEY^BLRGMENU(4)
  1.  Q
  1.  ;
  1. FINDSOMI ; EP - Initialization
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  S LASTYEAR=+$P($$HTE^XLFDT((+$H-(365*2)),"5D"),"/",3)
  1.  ;
  1.  S HEADER(1)="RPMS Lab Meaningful Use Stage 2"
  1.  S HEADER(2)="Patients with PROBLEMS since "_LASTYEAR_" and Have ORDERS"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  W !!,?4,"Compilation of Data"
  1.  ;
  1.  S HEADER(3)=" "
  1.  S $E(HEADER(4),50)="Total",$E(HEADER(4),60)="Cur 'YR'"
  1.  S HEADER(5)="DFN",$E(HEADER(5),10)="Patient Name"
  1.  S $E(HEADER(5),40)="LRDFN",$E(HEADER(5),50)="# Probs"
  1.  S $E(HEADER(5),60)="# Probs",$E(HEADER(5),70)="# Ords"
  1.  ;
  1.  S DFN=.9999999,MAX=13
  1.  S (CNT,DFNCNT,DFNLABS,DFNORDS)=0
  1.  Q
  1.  ;
  1. FINDSOML ; EP - Line of Data
  1.  S DFNCNT=DFNCNT+1
  1.  I DFNCNT<1 W:(DFNCNT#1000)=0 "."  W:$X>74 !,?4
  1.  ;
  1.  Q:$D(^DPT(DFN,"LR"))<1      ; Skip if no Labs
  1.  ;
  1.  S DFNLABS=DFNLABS+1         ; Patients with Labs
  1.  ;
  1.  S LRDFN=+$G(^DPT(DFN,"LR"))
  1.  Q:+$O(^LRO(69,"D",LRDFN,0))<1    ; Skip if no orders
  1.  ;
  1.  S DFNORDS=DFNORDS+1    ; Patients with Orders
  1.  ; 
  1.  S STR=$$CNTPROBS(DFN)
  1.  Q:+STR<1               ; Skip if no problems within the past year
  1.  ;
  1.  D:CNT<1 HEADERDT^BLRGMENU
  1.  ;
  1.  W DFN
  1.  W ?9,$P($G(^DPT(DFN,0)),"^")
  1.  W ?39,LRDFN
  1.  W ?49,$P(STR,"^",2)
  1.  W ?59,$P(STR,"^")
  1.  W ?69,$$CNTORDRS(LRDFN)
  1.  W !
  1.  S CNT=CNT+1
  1.  Q
  1.  ;
  1. CNTPROBS(DFN) ; EP
  1.  NEW (DFN,DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LASTYEAR,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S (NUMPROBS,NUMCPRBS)=0,PROBS="AAA"
  1.  F  S PROBS=$O(^AUPNPROB("AC",DFN,PROBS),-1)  Q:PROBS<1  D      ; Reverse Sort
  1.  . S STR=$G(^AUPNPROB(PROBS,0))
  1.  . S YRENTRY=$P($$FMTE^XLFDT($P(STR,"^",8),"5D"),"/",3)
  1.  . S:YRENTRY'<LASTYEAR NUMCPRBS=NUMCPRBS+1    ; If Entry Date >= Year Ago, count as "current"
  1.  . S NUMPROBS=NUMPROBS+1
  1.  ;
  1.  Q NUMCPRBS_"^"_NUMPROBS
  1.  ;
  1. CNTORDRS(LRDFN) ; EP 
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRDFN,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S LRODT=.9999999,CNTORDS=0
  1.  F  S LRODT=$O(^LRO(69,"D",LRDFN,LRODT))  Q:LRODT<1  D
  1.  . S LROT=.9999999
  1.  . F  S LROT=$O(^LRO(69,"D",LRDFN,LRODT,LROT))  Q:LROT<1  S CNTORDS=CNTORDS+1
  1.  ;
  1.  Q CNTORDS
  1.  ;
  1. FINDNONE ; EP - Find some patients that DO have lab orders but DO NOT have an entry in the Problem file.
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  D FINDNONI
  1.  ;
  1.  F  S LRODT=$O(^LRO(69,LRODT),-1)  Q:LRODT<1!(CNT>MAX)  D
  1.  . S LRSN="A"
  1.  . F  S LRSN=$O(^LRO(69,LRODT,1,LRSN),-1)  Q:LRSN<1!(CNT>MAX)  D
  1.  .. S LRDFN=+$G(^LRO(69,LRODT,1,LRSN,0))
  1.  .. S DFN=+$P($G(^LR(LRDFN,0)),"^",3)
  1.  .. Q:$D(STORDFN(DFN))                   ; Skip if patient aready accounted for
  1.  .. ;
  1.  .. S STORDFN(DFN)=LRDFN
  1.  .. Q:$D(^AUPNPROB("AC",DFN))            ; Skip if entry exists in 9000011
  1.  .. ;
  1.  .. S CNT=CNT+1
  1.  .. S NOPROB(DFN)=LRDFN
  1.  ;
  1.  S DFN=0,CNT=0
  1.  F  S DFN=$O(NOPROB(DFN))  Q:DFN<1!(QFLG="Q")  D
  1.  . S LRDFN=$G(NOPROB(DFN))
  1.  . ;
  1.  . I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,"NO")  Q:QFLG="Q"
  1.  . W DFN,?9,$$GET1^DIQ(2,DFN,"NAME"),?39,LRDFN,!  S LINES=LINES+1
  1.  ;
  1.  W !!
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. FINDNONI ; EP - Initialization
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  S BLRVERN2="FINDNONE"
  1.  ;
  1.  S HEADER(1)="RPMS Lab Meaningful Use Stage 2"
  1.  S HEADER(2)="Patients with ORDERS"
  1.  S HEADER(3)=$$CJ^XLFSTR("But NO Problem (#9000011) File Entries",IOM)
  1.  S HEADER(4)=" "
  1.  S HEADER(5)="DFN",$E(HEADER(5),10)="Patient Name",$E(HEADER(5),40)="LRDFN"
  1.  ;
  1.  S LRODT=$$HTFM^XLFDT(+$H+1),CNT=0,MAX=18
  1.  S PG=0,MAXLINES=IOSL-4,LINES=MAXLINES+10,QFLG="NO"
  1.  Q
  1.  ;
  1. SHOAPROB ; EP - Select Patient and Display ALL entries in Problem File
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  Q:$$SHOAPRBI()="Q"
  1.  ;
  1.  F  S IEN=$O(^AUPNPROB("AC",DFN,IEN))  Q:IEN<1!(QFLG="Q")  D SHOAPRBL
  1.  ;
  1.  D:QFLG'="Q" PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1. SHOAPRBI() ; EP - Initialization
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  ;
  1.  S HEADER(1)="RPMS Lab Meaningful Use Stage 2"
  1.  S HEADER(2)="Select 'Clinical Indication' Debug"
  1.  ;
  1.  ; Get Patient
  1.  S HEADER(3)=$$CJ^XLFSTR("Select Patient",IOM)
  1.  D HEADERDT^BLRGMENU
  1.  S DFN=0
  1.  F  Q:DFN!(DFN<0)  D
  1.  . S LRLOOKUP=1
  1.  . K DIC,LRDPAF,%DT("B") S DIC(0)="A"
  1.  . D ^LRDPA
  1.  ;
  1.  Q:DFN<0 "Q"   ; Skip if no patient selected
  1.  ;
  1.  K HEADER(3)
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  D HEADONE^BLRGMENU(.HDRONE)
  1.  ;
  1.  S HEADER(3)=$$CJ^XLFSTR("Patient Name:"_$P($G(^DPT(DFN,0)),"^"),IOM)
  1.  S HEADER(4)=$$CJ^XLFSTR("Problem File Listing",IOM)
  1.  S HEADER(5)=" "
  1.  S HEADER(6)="IEN",$E(HEADER(6),10)="Entry Dt",$E(HEADER(6),22)="ICD"
  1.  S $E(HEADER(6),32)="ICD Description",$E(HEADER(6),52)="Provider Narrative"
  1.  ;
  1.  S LASTYEAR=+$P($$HTE^XLFDT((+$H-(365*2)),"5D"),"/",3)
  1.  ;
  1.  S MAXLINES=22,LINES=MAXLINES+10,(CNT,PG)=0,QFLG="NO"
  1.  ;
  1.  S IEN=.9999999,CNT=0
  1.  Q "OK"
  1.  ;
  1. SHOAPRBL ; EP - Line of Data
  1.  Q:$$CHKPROBV()="Q"  ; Breakout Variables.  Skip if there is an issue.
  1.  ;
  1.  I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLG,HDRONE)  Q:QFLG="Q"
  1.  ;
  1.  S CNT=CNT+1
  1.  W IEN,?9,ENTERDT,?21,ICDCODE,?31,$E(ICDDESC,1,18)
  1.  D LINEWRAP^BLRGMENU(51,PROVNDES,29)
  1.  W !
  1.  S LINES=LINES+1
  1.  Q
  1.  ;
  1. FINDNOLA ; EP - Find some patients that have a problem list but NO lab orders
  1.  NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
  1.  ;
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  S LASTYEAR=+$P($$HTE^XLFDT((+$H-(365*2)),"5D"),"/",3)
  1.  ;
  1.  S HEADER(1)="RPMS Lab Meaningful Use Stage 2"
  1.  S HEADER(2)="Patients with PROBLEMS since "_LASTYEAR_" and have No Lab ORDERS"
  1.  ;
  1.  D HEADERDT^BLRGMENU
  1.  W !!,?4,"Compilation of Data"
  1.  ;
  1.  S HEADER(3)=" "
  1.  S $E(HEADER(4),50)="Total"
  1.  S $E(HEADER(4),60)="Cur 'YR'"
  1.  S HEADER(5)="DFN"
  1.  S $E(HEADER(5),10)="Patient Name",$E(HEADER(5),40)="LRDFN"
  1.  S $E(HEADER(5),50)="# Probs",$E(HEADER(5),60)="# Probs"
  1.  ; S $E(HEADER(5),70)="# Ords"
  1.  ;
  1.  S DFN=.9999999,CNT=0,MAX=13,DFNCNT=0
  1.  F  S DFN=$O(^AUPNPROB("AC",DFN))  Q:DFN<1!(CNT>MAX)  D
  1.  . ; Q:$D(^DPT(DFN,"LR"))
  1.  . S LRDFN=+$$GET1^DIQ(2,DFN,"LABORATORY REFERENCE","I")
  1.  . ;
  1.  . I CNT<1 W:(DFNCNT#1000)=0 "."  W:$X>74 !,?4
  1.  . S DFNCNT=DFNCNT+1
  1.  . ;
  1.  . S STR=$$CNTPROBS(DFN)
  1.  . Q:+STR<1               ; Skip if no problems within the past year
  1.  . ;
  1.  . Q:$$CNTORDRS(LRDFN)    ; Skip if any orders
  1.  . ;
  1.  . D:CNT<1 HEADERDT^BLRGMENU
  1.  . ;
  1.  . W DFN
  1.  . W ?9,$P($G(^DPT(DFN,0)),"^")
  1.  . W ?49,$P(STR,"^",2)
  1.  . W ?59,$P(STR,"^")
  1.  . W !
  1.  . S CNT=CNT+1
  1.  ;
  1.  D PRESSKEY^BLRGMENU(9)
  1.  Q
  1.  ;
  1.  ;
  1.  ; Utilities follow
  1.  ;
  1. CHKPROBV() ; EP - Check the "Break Out" Variables from Problem List
  1.  D BREAKOUT
  1.  ;
  1.  ; Q:STATUS'="A" "Q"   ; If problem's status is not active, skip
  1.  ;
  1.  ; Q:ICDCODE=799.99 "Q"               ; Skip generic ICD code
  1.  ; Q:ICDCODE=.9999 "Q"                ; Skip "Uncoded" code
  1.  ;
  1.  Q "OK"
  1.  ;
  1. BREAKOUT ; EP - Breakout variables from PROBLEM file
  1.  S STATUS=$$GET1^DIQ(9000011,IEN,"STATUS","I")
  1.  ;
  1.  S CONCID=$$GET1^DIQ(9000011,IEN,"SNOMED CT CONCEPT CODE","I")
  1.  S ENTERDT=+$P($$GET1^DIQ(9000011,IEN,"DATE ENTERED","I"),".")
  1.  S:ENTERDT $P(CONCID,"^",3)=ENTERDT    ; Make sure current codes as of Enter 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.  ; S ICDDESC=$P($$ICDDX^ICDCODE(ICDCODE),"^",4)
  1.  S ICDDESC=$P($$ICDDX^ICDEX(ICDCODE),"^",4)      ; IHS/MSC/MKK - LR*5.2*1034
  1.  ;
  1.  S ENTERDT=$$GET1^DIQ(9000011,IEN,"DATE ENTERED","I")
  1.  S ENTERDT=$S(ENTERDT:$$FMTE^XLFDT(ENTERDT,"5DZ"),1:" ")
  1.  ;
  1.  S LASTMODD=$$GET1^DIQ(9000011,IEN,"DATE LAST MODIFIED","I")
  1.  S LASTMODD=$S(LASTMODD:$$FMTE^XLFDT(LASTMODD,"5DZ"),1:" ")
  1.  ;
  1.  S PROVNDES=$$GET1^DIQ(9000011,IEN,"PROVIDER NARRATIVE")
  1.  S PROVNDES=$$TRIM^XLFSTR(PROVNDES,"L","*")      ; Get rid of leading "*"
  1.  Q
  1.  ;
  1. SETHEAD(HD,COL,WOT) ; EP - Set the HEADER array
  1.  I HD<3 S HEADER(HD)=WOT  Q
  1.  ;
  1.  I +$G(COL)<1 S HEADER(HD)=$$CJ^XLFSTR(WOT,IOM)  Q
  1.  ;
  1.  S $E(HEADER(HD),COL)=WOT
  1.  Q
  1.  ;
  1. ICDCODE ; EP
  1.  S (ICD,ICDCNT)=0
  1.  F  S ICD=$O(^LRO(69,LRODT,1,LRSP,2,TEST,2,ICD))  Q:ICD<1  D
  1.  . S ICDCNT=ICDCNT+1
  1.  . S IENS=ICD_","_TEST_","_LRSP_","_LRODT
  1.  . ; S STR=$$ICDDX^ICDCODE($$GET1^DIQ(69.05,IENS,"ICD-9 CODES","I"))
  1.  . S STR=$$ICDDX^ICDEX($$GET1^DIQ(69.05,IENS,"ICD CODES","I"))     ; IHS/MSC/MKK - LR*5.2*1034
  1.  . ;
  1.  . W:ICDCNT=1 ?24,"ICD:"
  1.  . S ICDDESC=$P(STR,"^",4)
  1.  . W ?28,$P(STR,"^",2)  S TAB=$X+2
  1.  . W:$L(ICDDESC)<(70-TAB) ?38,ICDDESC
  1.  . D:$L(ICDDESC)>(70-TAB) LINEWRAP^BLRGMENU(TAB,ICDDESC,(70-TAB))
  1.  . W !
  1.  Q
  1.  ;
  1. SETBLRVS(TWO) ; EP - Set BLRVERN variable(s)
  1.  S BLRVERN=$TR($P($T(+1),";")," ")
  1.  S:$L($G(TWO)) BLRVERN2=TWO
  1.  Q