BLRLOINC ;IHS/OIT/MKK - IHS LAB LOINC REPORT [ 12/19/2002 7:25 AM ]
;;5.2;LR;**1024**;May 2, 2008
;;
EEP ; Ersatz EP
W !!
W ">>>>>>>>>>>>"
W " USE LABEL "
W "<<<<<<<<<<<<"
W !!
Q
;
EP ; EP -- Main Entry Point
NEW CNTLOINC,PTRLOINC,CNTLT,CNTZZ
NEW QFLG,SITESPEC,STR
;
D COMLOINC ; Count Lab Tests with LOINC Codes
;
D REPORT ; Output Results
;
Q
COMLOINC ; EP - Compile Listing of Tests with LOINC Codes
S (CNTLOINC,FLAG,CNTLT,TEST,CNTZZ)=0
F S TEST=$O(^LAB(60,TEST)) Q:TEST=""!(TEST'?.N) D
. S CNTLT=CNTLT+1 ; Count # of Lab Tests in dictionary
. ;
. ; Count # of Lab Tests that have a Name that begin with Two Z's
. I $E($P($G(^LAB(60,TEST,0)),"^",1),1,2)="ZZ" S CNTZZ=CNTZZ+1
. ;
. ; LOINC Codes are stored in the SITE/SPECIMEN multiple, so have to
. ; go through the multiple and determine if there is a LOINC Code
. S (FLAG,SITESPEC)=0
. F S SITESPEC=$O(^LAB(60,TEST,1,SITESPEC)) Q:SITESPEC=""!(SITESPEC'?.N)!(FLAG) D
.. I +$G(^LAB(60,TEST,1,SITESPEC,95.3))>0 S FLAG=1 ; LOINC
. ;
. I FLAG S CNTLOINC=CNTLOINC+1
;
Q
;
REPORT ; EP - Results
NEW LN,LRLRPT,TAB,TFLAG
;
D BUILDARY ; Build the Array
;
D REPORTIT ; Output the results
;
Q
;
BUILDARY ; EP
NEW NOLOINC
;
S NOLOINC=CNTLT-CNTLOINC
;
S TAB=$J("",5)
S LN=0
D ADDLNCJ($$LOC^XBFUNC,.LN)
D ADDLNCJ("Logical Observation Identifiers",.LN,"YES","YES")
D ADDLNCJ("Names and Codes (LOINC)",.LN)
D ADDLNCJ("IHS Percentages Report",.LN)
D ADDLNCJ($TR($J("",IOM)," ","-"),.LN)
;
D ADDLINE(" ",.LN)
D ADDLINE("Number of Lab Tests in Dictionary = "_CNTLT,.LN)
D ADDLINE(" ",.LN)
;
I CNTLOINC<1 D
. D ADDLINE(TAB_"Not a single Lab Test has a LOINC Code",.LN)
. D ADDLINE(" ",.LN)
;
I +$G(CNTZZ)>0 D
. D ADDLINE(TAB_"Number of ZZ'ed Lab Tests in Dictionary = "_CNTZZ,.LN)
. D ADDLINE(" ",.LN)
;
D ADDLINE(TAB_"Number of Lab Tests in Dictionary with LOINC codes = "_CNTLOINC,.LN)
D ADDLINE(" ",.LN)
;
D ADDLINE(TAB_"Number of Lab Tests in Dictionary without LOINC codes = "_NOLOINC,.LN)
D ADDLINE(" ",.LN)
;
D ADDLINE(TAB_"Percentage of Lab Tests in File 60 with LOINC codes = "_($FN((CNTLOINC/CNTLT),"",3)*100)_"%",.LN)
D ADDLINE(" ",.LN)
;
I (CNTLT-CNTZZ)>0 D
. D ADDLINE(TAB_"Percentage of Non ZZ'ed Lab Tests in File 60 with LOINC codes = "_($FN((CNTLOINC/(CNTLT-CNTZZ)),"",3)*100)_"%",.LN)
. D ADDLINE(" ",.LN)
Q
;
ADDLNCJ(MIDSTR,LN,LEFTSTR,RGHTSTR) ; EP
S LN=LN+1
S LRLRPT(LN)=$$CJ^XLFSTR(MIDSTR,IOM)
;
; Today's Date
S:$G(LEFTSTR)'="" $E(LRLRPT(LN),1,13)="Date:"_$$HTE^XLFDT($H,"2DZ")
;
; Current Time
S:$G(RGHTSTR)'="" $E(LRLRPT(LN),IOM-15)=$J("Time:"_$$UP^XLFSTR($P($$HTE^XLFDT($H,"2MPZ")," ",2,3)),16)
;
; Trim extra spaces
S:$G(LEFTSTR)'=""!($G(RGHTSTR)'="") LRLRPT(LN)=$$TRIM^XLFSTR(LRLRPT(LN),"R"," ")
;
Q
;
ADDLINE(ADDSTR,LN) ; EP
S LN=LN+1
S LRLRPT(LN)=$$LJ^XLFSTR(ADDSTR,IOM)
Q
;
REPORTIT ; EP
S %ZIS="Q"
D ^%ZIS
I POP D
. W !!,?10,"DEVICE could not be selected. Output will be to the screen.",!!
;
I $D(IO("Q")) D Q
. S ZTRTN="DQ^BLRLOINC",ZTDESC="IHS LOINC Percentage Report"
. S ZTSAVE("LR*")=""
. S ZTSAVE("CNT*")=""
. D ^%ZTLOAD,^%ZISC
. W !,"Request ",$S($G(ZTSK):"Queued - Task #"_ZTSK,1:"NOT Queued"),!!
. D BLREND
. D PRESSIT
;
DQ ; EP
;
U IO
I $E(IOST,1,2)="C-" D ^XBCLS ; If terminal, clear sceen & home cursor
; I IOST'["C-VT" W @IOF ; Form Feed if not terminal
;
D EN^DDIOL(.LRLRPT) ; Display the array
;
I $D(ZTQUEUED) Q ; If Queued, QUIT
;
D ^%ZISC ; Close all the devices
D PRESSIT
;
Q
;
; Just Prompt and quit
PRESSIT ; EP
D ^XBFMK
S DIR("A")=$J("",10)_"Press RETURN Key"
S DIR(0)="FO^1:1"
D ^DIR
Q
;
; Called when Queued
BLREND ; EP
I $E(IOST,1,2)="P-" W @IOF
I $D(ZTQUEUED) S ZTREQ="@"
E D ^%ZISC
D KVA^VADPT
Q
BLRLOINC ;IHS/OIT/MKK - IHS LAB LOINC REPORT [ 12/19/2002 7:25 AM ]
+1 ;;5.2;LR;**1024**;May 2, 2008
+2 ;;
EEP ; Ersatz EP
+1 WRITE !!
+2 WRITE ">>>>>>>>>>>>"
+3 WRITE " USE LABEL "
+4 WRITE "<<<<<<<<<<<<"
+5 WRITE !!
+6 QUIT
+7 ;
EP ; EP -- Main Entry Point
+1 NEW CNTLOINC,PTRLOINC,CNTLT,CNTZZ
+2 NEW QFLG,SITESPEC,STR
+3 ;
+4 ; Count Lab Tests with LOINC Codes
DO COMLOINC
+5 ;
+6 ; Output Results
DO REPORT
+7 ;
+8 QUIT
COMLOINC ; EP - Compile Listing of Tests with LOINC Codes
+1 SET (CNTLOINC,FLAG,CNTLT,TEST,CNTZZ)=0
+2 FOR
SET TEST=$ORDER(^LAB(60,TEST))
IF TEST=""!(TEST'?.N)
QUIT
Begin DoDot:1
+3 ; Count # of Lab Tests in dictionary
SET CNTLT=CNTLT+1
+4 ;
+5 ; Count # of Lab Tests that have a Name that begin with Two Z's
+6 IF $EXTRACT($PIECE($GET(^LAB(60,TEST,0)),"^",1),1,2)="ZZ"
SET CNTZZ=CNTZZ+1
+7 ;
+8 ; LOINC Codes are stored in the SITE/SPECIMEN multiple, so have to
+9 ; go through the multiple and determine if there is a LOINC Code
+10 SET (FLAG,SITESPEC)=0
+11 FOR
SET SITESPEC=$ORDER(^LAB(60,TEST,1,SITESPEC))
IF SITESPEC=""!(SITESPEC'?.N)!(FLAG)
QUIT
Begin DoDot:2
+12 ; LOINC
IF +$GET(^LAB(60,TEST,1,SITESPEC,95.3))>0
SET FLAG=1
End DoDot:2
+13 ;
+14 IF FLAG
SET CNTLOINC=CNTLOINC+1
End DoDot:1
+15 ;
+16 QUIT
+17 ;
REPORT ; EP - Results
+1 NEW LN,LRLRPT,TAB,TFLAG
+2 ;
+3 ; Build the Array
DO BUILDARY
+4 ;
+5 ; Output the results
DO REPORTIT
+6 ;
+7 QUIT
+8 ;
BUILDARY ; EP
+1 NEW NOLOINC
+2 ;
+3 SET NOLOINC=CNTLT-CNTLOINC
+4 ;
+5 SET TAB=$JUSTIFY("",5)
+6 SET LN=0
+7 DO ADDLNCJ($$LOC^XBFUNC,.LN)
+8 DO ADDLNCJ("Logical Observation Identifiers",.LN,"YES","YES")
+9 DO ADDLNCJ("Names and Codes (LOINC)",.LN)
+10 DO ADDLNCJ("IHS Percentages Report",.LN)
+11 DO ADDLNCJ($TRANSLATE($JUSTIFY("",IOM)," ","-"),.LN)
+12 ;
+13 DO ADDLINE(" ",.LN)
+14 DO ADDLINE("Number of Lab Tests in Dictionary = "_CNTLT,.LN)
+15 DO ADDLINE(" ",.LN)
+16 ;
+17 IF CNTLOINC<1
Begin DoDot:1
+18 DO ADDLINE(TAB_"Not a single Lab Test has a LOINC Code",.LN)
+19 DO ADDLINE(" ",.LN)
End DoDot:1
+20 ;
+21 IF +$GET(CNTZZ)>0
Begin DoDot:1
+22 DO ADDLINE(TAB_"Number of ZZ'ed Lab Tests in Dictionary = "_CNTZZ,.LN)
+23 DO ADDLINE(" ",.LN)
End DoDot:1
+24 ;
+25 DO ADDLINE(TAB_"Number of Lab Tests in Dictionary with LOINC codes = "_CNTLOINC,.LN)
+26 DO ADDLINE(" ",.LN)
+27 ;
+28 DO ADDLINE(TAB_"Number of Lab Tests in Dictionary without LOINC codes = "_NOLOINC,.LN)
+29 DO ADDLINE(" ",.LN)
+30 ;
+31 DO ADDLINE(TAB_"Percentage of Lab Tests in File 60 with LOINC codes = "_($FNUMBER((CNTLOINC/CNTLT),"",3)*100)_"%",.LN)
+32 DO ADDLINE(" ",.LN)
+33 ;
+34 IF (CNTLT-CNTZZ)>0
Begin DoDot:1
+35 DO ADDLINE(TAB_"Percentage of Non ZZ'ed Lab Tests in File 60 with LOINC codes = "_($FNUMBER((CNTLOINC/(CNTLT-CNTZZ)),"",3)*100)_"%",.LN)
+36 DO ADDLINE(" ",.LN)
End DoDot:1
+37 QUIT
+38 ;
ADDLNCJ(MIDSTR,LN,LEFTSTR,RGHTSTR) ; EP
+1 SET LN=LN+1
+2 SET LRLRPT(LN)=$$CJ^XLFSTR(MIDSTR,IOM)
+3 ;
+4 ; Today's Date
+5 IF $GET(LEFTSTR)'=""
SET $EXTRACT(LRLRPT(LN),1,13)="Date:"_$$HTE^XLFDT($HOROLOG,"2DZ")
+6 ;
+7 ; Current Time
+8 IF $GET(RGHTSTR)'=""
SET $EXTRACT(LRLRPT(LN),IOM-15)=$JUSTIFY("Time:"_$$UP^XLFSTR($PIECE($$HTE^XLFDT($HOROLOG,"2MPZ")," ",2,3)),16)
+9 ;
+10 ; Trim extra spaces
+11 IF $GET(LEFTSTR)'=""!($GET(RGHTSTR)'="")
SET LRLRPT(LN)=$$TRIM^XLFSTR(LRLRPT(LN),"R"," ")
+12 ;
+13 QUIT
+14 ;
ADDLINE(ADDSTR,LN) ; EP
+1 SET LN=LN+1
+2 SET LRLRPT(LN)=$$LJ^XLFSTR(ADDSTR,IOM)
+3 QUIT
+4 ;
REPORTIT ; EP
+1 SET %ZIS="Q"
+2 DO ^%ZIS
+3 IF POP
Begin DoDot:1
+4 WRITE !!,?10,"DEVICE could not be selected. Output will be to the screen.",!!
End DoDot:1
+5 ;
+6 IF $DATA(IO("Q"))
Begin DoDot:1
+7 SET ZTRTN="DQ^BLRLOINC"
SET ZTDESC="IHS LOINC Percentage Report"
+8 SET ZTSAVE("LR*")=""
+9 SET ZTSAVE("CNT*")=""
+10 DO ^%ZTLOAD
DO ^%ZISC
+11 WRITE !,"Request ",$SELECT($GET(ZTSK):"Queued - Task #"_ZTSK,1:"NOT Queued"),!!
+12 DO BLREND
+13 DO PRESSIT
End DoDot:1
QUIT
+14 ;
DQ ; EP
+1 ;
+2 USE IO
+3 ; If terminal, clear sceen & home cursor
IF $EXTRACT(IOST,1,2)="C-"
DO ^XBCLS
+4 ; I IOST'["C-VT" W @IOF ; Form Feed if not terminal
+5 ;
+6 ; Display the array
DO EN^DDIOL(.LRLRPT)
+7 ;
+8 ; If Queued, QUIT
IF $DATA(ZTQUEUED)
QUIT
+9 ;
+10 ; Close all the devices
DO ^%ZISC
+11 DO PRESSIT
+12 ;
+13 QUIT
+14 ;
+15 ; Just Prompt and quit
PRESSIT ; EP
+1 DO ^XBFMK
+2 SET DIR("A")=$JUSTIFY("",10)_"Press RETURN Key"
+3 SET DIR(0)="FO^1:1"
+4 DO ^DIR
+5 QUIT
+6 ;
+7 ; Called when Queued
BLREND ; EP
+1 IF $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 IF '$TEST
DO ^%ZISC
+4 DO KVA^VADPT
+5 QUIT
