- 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
