BLRNLOIN ;IHS/OIT/MKK - IHS LAB NO LOINC REPORT [ 02/05/2008 1:25 PM ]
;;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,CNTNLOI
NEW QFLG,SITESPEC,STR
NEW LABTNME,NOLOINC
;
D NCNTLNC ; Count Lab Tests without LOINC Codes
;
I CNTNLOI<1 D Q
. W !,"All Tests in File 60 Have LOINC Codes.",!
. W "Program Finished",!!
. D PRESSIT
;
D REPORT ; Output Results
;
D PRESSIT ; Press RETURN key
;
Q
;
NCNTLNC ; EP -- Compile listing of tests without LOINC codes
D NCNTLNCI ; Initialize variables
;
F S TEST=$O(^LAB(60,TEST)) Q:TEST=""!(TEST'?.N) D
. ; Warm fuzzy to user
. W "."
. I $X>78 W !
. ;
. ; Skip all COSMIC tests -- I don't belive you can LOINC panels
. I +$O(^LAB(60,TEST,2,0))>0 Q
. ;
. S CNTLT=CNTLT+1 ; Count # of ATOMIC 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
. ;
. ; There is a LOINC, so count it and go to next test
. I FLAG S CNTLOINC=CNTLOINC+1 Q
. ;
. ; There is no LOINC; Build array of such tests -- alpha sort by name
. S LABTNME=$P($G(^LAB(60,TEST,0)),"^",1) ; Lab Test Name
. S NOLOINC(LABTNME)=TEST ; Store data
. S CNTNLOI=CNTNLOI+1 ; Count them
;
Q
;
NCNTLNCI ; EP -- Initialize variables
W !
S (CNTLOINC,FLAG,CNTLT,TEST,CNTZZ,CNTNLOI)=0
D ^XBCLS
W $$CJ^XLFSTR("Going through LAB TEST FILE (# 60)",IOM),!!
Q
;
REPORT ; EP - Results
NEW LN,LRLRPT,TAB,TFLAG
NEW HEADER,PG,QFLAG,LINES,MAXLINES
;
I $$OKAYGO'="Y" Q ; Want to go on?
;
D BUILDARY ; Build the array for output
;
D REPORTIT ; Output the results
;
Q
OKAYGO() ; EP
W !!
W "There are ",CNTNLOI," Lab Tests WITHOUT LOINC codes"
W !!
W ?5,"The Detailed report will be approximately ",(CNTNLOI\55)," printed pages long"
W !!
D ^XBFMK
S DIR("A")="Do you want to continue"
S DIR("B")="NO"
S DIR(0)="YO"
D ^DIR
I $E($$UP^XLFSTR(X),1,1)="N"!(+$G(DUOUT)) D Q "NO"
. W !!
. W ?10,"Program exiting",!
;
Q "Y"
;
BUILDARY ; EP -- Build the output array
S TAB=$J("",5)
S LN=0
D ADDLNCJ($$LOC^XBFUNC,.LN)
D ADDLNCJ("Logical Observation Identifiers",.LN)
D ADDLNCJ("Names and Codes (LOINC)",.LN)
D ADDLNCJ("IHS Lab Test File (# 60)",.LN)
D ADDLNCJ("Tests WITHOUT Codes",.LN)
D ADDLINE(" ",.LN)
D ADDLINE(TAB_"File 60",.LN)
D ADDLINE(TAB_"Number"_" File 60 Description",.LN)
D ADDLNCJ($TR($J("",IOM)," ","-"),.LN)
;
S LABTNME=""
F S LABTNME=$O(NOLOINC(LABTNME)) Q:LABTNME="" D
. S TEST=$G(NOLOINC(LABTNME))
. D ADDLINE(" "_$J(TEST,8)_" "_$E(LABTNME,1,55),.LN)
;
D ADDLINE(" ",.LN)
D ADDLINE("Number of Lab Tests Without LOINC Code = "_CNTNLOI,.LN)
D ADDLINE(" ",.LN)
;
D ADDLINE(TAB_"Number of Lab Tests in Dictionary = "_CNTLT,.LN)
D ADDLINE(" ",.LN)
;
D ADDLINE(TAB_"Number of Lab Tests in Dictionary with LOINC codes = "_CNTLOINC,.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)
;
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 -- Report the data
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="DEVRPT^BLRNLOIN",ZTDESC="IHS Non LOINC Lab Tests Report"
. S ZTSAVE("LR*")=""
. S ZTSAVE("CNT*")=""
. D ^%ZTLOAD,^%ZISC
. W !,"Request ",$S($G(ZTSK):"Queued - Task #"_ZTSK,1:"NOT Queued"),!!
. D BLREND
;
DEVRPT ; EP
D DEVRPTIN
;
U IO
F Q:$G(LRLRPT(J))=""!(QFLAG="Q") D
. I LINES>MAXLINES D HEADERPG^BLRGMENU(.PG,.QFLAG,"NO") I QFLAG="Q" Q
. ;
. S J=J+1
. W $G(LRLRPT(J))
. S LINES=LINES+1
;
D ^%ZISC
;
Q
;
DEVRPTIN ; EP -- Initialize variables
S (PG,CNT)=0
S MAXLINES=IOSL-3
S LINES=MAXLINES+10
S QFLAG="NO"
K HEADER
F J=2:1:8 S HEADER(J-1)=LRLRPT(J)
;
S J=10
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
BLRNLOIN ;IHS/OIT/MKK - IHS LAB NO LOINC REPORT [ 02/05/2008 1:25 PM ]
+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,CNTNLOI
+2 NEW QFLG,SITESPEC,STR
+3 NEW LABTNME,NOLOINC
+4 ;
+5 ; Count Lab Tests without LOINC Codes
DO NCNTLNC
+6 ;
+7 IF CNTNLOI<1
Begin DoDot:1
+8 WRITE !,"All Tests in File 60 Have LOINC Codes.",!
+9 WRITE "Program Finished",!!
+10 DO PRESSIT
End DoDot:1
QUIT
+11 ;
+12 ; Output Results
DO REPORT
+13 ;
+14 ; Press RETURN key
DO PRESSIT
+15 ;
+16 QUIT
+17 ;
NCNTLNC ; EP -- Compile listing of tests without LOINC codes
+1 ; Initialize variables
DO NCNTLNCI
+2 ;
+3 FOR
SET TEST=$ORDER(^LAB(60,TEST))
IF TEST=""!(TEST'?.N)
QUIT
Begin DoDot:1
+4 ; Warm fuzzy to user
+5 WRITE "."
+6 IF $X>78
WRITE !
+7 ;
+8 ; Skip all COSMIC tests -- I don't belive you can LOINC panels
+9 IF +$ORDER(^LAB(60,TEST,2,0))>0
QUIT
+10 ;
+11 ; Count # of ATOMIC Lab Tests in dictionary
SET CNTLT=CNTLT+1
+12 ;
+13 ; Count # of Lab Tests that have a Name that begin with Two Z's
+14 IF $EXTRACT($PIECE($GET(^LAB(60,TEST,0)),"^",1),1,2)="ZZ"
SET CNTZZ=CNTZZ+1
+15 ;
+16 ; LOINC Codes are stored in the SITE/SPECIMEN multiple, so have to
+17 ; go through the multiple and determine if there is a LOINC Code
+18 SET (FLAG,SITESPEC)=0
+19 FOR
SET SITESPEC=$ORDER(^LAB(60,TEST,1,SITESPEC))
IF SITESPEC=""!(SITESPEC'?.N)!(FLAG)
QUIT
Begin DoDot:2
+20 ; LOINC
IF +$GET(^LAB(60,TEST,1,SITESPEC,95.3))>0
SET FLAG=1
End DoDot:2
+21 ;
+22 ; There is a LOINC, so count it and go to next test
+23 IF FLAG
SET CNTLOINC=CNTLOINC+1
QUIT
+24 ;
+25 ; There is no LOINC; Build array of such tests -- alpha sort by name
+26 ; Lab Test Name
SET LABTNME=$PIECE($GET(^LAB(60,TEST,0)),"^",1)
+27 ; Store data
SET NOLOINC(LABTNME)=TEST
+28 ; Count them
SET CNTNLOI=CNTNLOI+1
End DoDot:1
+29 ;
+30 QUIT
+31 ;
NCNTLNCI ; EP -- Initialize variables
+1 WRITE !
+2 SET (CNTLOINC,FLAG,CNTLT,TEST,CNTZZ,CNTNLOI)=0
+3 DO ^XBCLS
+4 WRITE $$CJ^XLFSTR("Going through LAB TEST FILE (# 60)",IOM),!!
+5 QUIT
+6 ;
REPORT ; EP - Results
+1 NEW LN,LRLRPT,TAB,TFLAG
+2 NEW HEADER,PG,QFLAG,LINES,MAXLINES
+3 ;
+4 ; Want to go on?
IF $$OKAYGO'="Y"
QUIT
+5 ;
+6 ; Build the array for output
DO BUILDARY
+7 ;
+8 ; Output the results
DO REPORTIT
+9 ;
+10 QUIT
OKAYGO() ; EP
+1 WRITE !!
+2 WRITE "There are ",CNTNLOI," Lab Tests WITHOUT LOINC codes"
+3 WRITE !!
+4 WRITE ?5,"The Detailed report will be approximately ",(CNTNLOI\55)," printed pages long"
+5 WRITE !!
+6 DO ^XBFMK
+7 SET DIR("A")="Do you want to continue"
+8 SET DIR("B")="NO"
+9 SET DIR(0)="YO"
+10 DO ^DIR
+11 IF $EXTRACT($$UP^XLFSTR(X),1,1)="N"!(+$GET(DUOUT))
Begin DoDot:1
+12 WRITE !!
+13 WRITE ?10,"Program exiting",!
End DoDot:1
QUIT "NO"
+14 ;
+15 QUIT "Y"
+16 ;
BUILDARY ; EP -- Build the output array
+1 SET TAB=$JUSTIFY("",5)
+2 SET LN=0
+3 DO ADDLNCJ($$LOC^XBFUNC,.LN)
+4 DO ADDLNCJ("Logical Observation Identifiers",.LN)
+5 DO ADDLNCJ("Names and Codes (LOINC)",.LN)
+6 DO ADDLNCJ("IHS Lab Test File (# 60)",.LN)
+7 DO ADDLNCJ("Tests WITHOUT Codes",.LN)
+8 DO ADDLINE(" ",.LN)
+9 DO ADDLINE(TAB_"File 60",.LN)
+10 DO ADDLINE(TAB_"Number"_" File 60 Description",.LN)
+11 DO ADDLNCJ($TRANSLATE($JUSTIFY("",IOM)," ","-"),.LN)
+12 ;
+13 SET LABTNME=""
+14 FOR
SET LABTNME=$ORDER(NOLOINC(LABTNME))
IF LABTNME=""
QUIT
Begin DoDot:1
+15 SET TEST=$GET(NOLOINC(LABTNME))
+16 DO ADDLINE(" "_$JUSTIFY(TEST,8)_" "_$EXTRACT(LABTNME,1,55),.LN)
End DoDot:1
+17 ;
+18 DO ADDLINE(" ",.LN)
+19 DO ADDLINE("Number of Lab Tests Without LOINC Code = "_CNTNLOI,.LN)
+20 DO ADDLINE(" ",.LN)
+21 ;
+22 DO ADDLINE(TAB_"Number of Lab Tests in Dictionary = "_CNTLT,.LN)
+23 DO ADDLINE(" ",.LN)
+24 ;
+25 DO ADDLINE(TAB_"Number of Lab Tests in Dictionary with LOINC codes = "_CNTLOINC,.LN)
+26 DO ADDLINE(" ",.LN)
+27 ;
+28 IF +$GET(CNTZZ)>0
Begin DoDot:1
+29 DO ADDLINE(TAB_"Number of ZZ'ed Lab Tests in Dictionary = "_CNTZZ,.LN)
+30 DO ADDLINE(" ",.LN)
End DoDot:1
+31 ;
+32 QUIT
+33 ;
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 -- Report the data
+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="DEVRPT^BLRNLOIN"
SET ZTDESC="IHS Non LOINC Lab Tests 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
End DoDot:1
QUIT
+13 ;
DEVRPT ; EP
+1 DO DEVRPTIN
+2 ;
+3 USE IO
+4 FOR
IF $GET(LRLRPT(J))=""!(QFLAG="Q")
QUIT
Begin DoDot:1
+5 IF LINES>MAXLINES
DO HEADERPG^BLRGMENU(.PG,.QFLAG,"NO")
IF QFLAG="Q"
QUIT
+6 ;
+7 SET J=J+1
+8 WRITE $GET(LRLRPT(J))
+9 SET LINES=LINES+1
End DoDot:1
+10 ;
+11 DO ^%ZISC
+12 ;
+13 QUIT
+14 ;
DEVRPTIN ; EP -- Initialize variables
+1 SET (PG,CNT)=0
+2 SET MAXLINES=IOSL-3
+3 SET LINES=MAXLINES+10
+4 SET QFLAG="NO"
+5 KILL HEADER
+6 FOR J=2:1:8
SET HEADER(J-1)=LRLRPT(J)
+7 ;
+8 SET J=10
+9 QUIT
+10 ;
+11 ; 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
