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