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

BLRLOINC.m

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