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

BLSLNCPM.m

Go to the documentation of this file. 
  1. BLSLNCPM ;DALOI/FHS/TPF - PRINT LAB TESTS MAPPED/NOT MAPPED TO LOINC CODES - THIS IS MODIFIED TO PRINT OUT LOINC TESTS AS DEVELOPED BY CIMARRON FOR LAB PATCH 15
  1.  ;;5.2T9;LR;**1015,1017,1018**;Nov 17, 2004
  1.  ;;5.2;LAB SERVICE;**215,232,278**;Sep 27,1994
  1. EN ;
  1.  W @IOF K LRMAP,LREND
  1.  W !,$$CJ^XLFSTR("This option prints a list of the LABORATORY TESTS from the LABORATORY TEST FILE.",IOM)
  1.  W !,$$CJ^XLFSTR("You will be prompted to print lab tests that are",IOM)
  1.  W !,$$CJ^XLFSTR("mapped/not mapped to a LOINC code.",IOM)
  1.  W !,$$CJ^XLFSTR("Inactive(Type:Neither) lab tests are not reported.",IOM)
  1. WHICH ;
  1.  W !!!,"Print lab tests that are mapped/not mapped to a LOINC code."
  1.  K DIR,LRMAP
  1.  ;S DIR("?")="Select 1 for mapped, 0 for not mapped or 2 for Individual"
  1.  ;S DIR(0)="SO^0:Not Mapped;1:Mapped test;2:Individual Mapped Test" D ^DIR K DIR
  1.  ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
  1.  S DIR("?")="Select 1 for mapped or 0 for not mapped"
  1.  S DIR(0)="SO^0:Not Mapped;1:Mapped test" D ^DIR K DIR
  1.  I Y=""!($D(DIRUT)) D EXIT Q
  1.  S LRMAP=Y
  1.  D:+Y=2 SING G:$G(LREND) EXIT
  1.  K %ZIS S %ZIS="Q" D ^%ZIS G:POP EXIT
  1.  I $D(IO("Q")) D QUE Q
  1.  U IO D START,^%ZISC Q
  1. SING ; Select individual lab test for report
  1.  I LRMAP=2 D
  1.  . K LRMAP
  1.  . S LREND=0,LRMAP=2
  1.  . W !,$$CJ^XLFSTR("You can only select test that have been mapped.",IOM)
  1.  . W !,$$CJ^XLFSTR("You can a quick list of mapped tests by entering '?'.",IOM)
  1.  . W !,$$CJ^XLFSTR("Then enter 'Yes' you want a complete list.",IOM),!
  1.  . K DIR,X,Y
  1.  . S DIR(0)="PO^60:EZNMQ"
  1.  . S DIR("S")="I $S($D(^LAM(""AL"",+Y)):1,$D(^LAM(""AM"",+Y)):1,1:0)"
  1.  . S DIR("?")="You must select a Mapped LABORATORY TEST"
  1.  . F  D ^DIR Q:Y<1!($D(DIRUT))  S LRMAP(+Y)=Y
  1.  . I '$O(LRMAP(0)) W !!?5,"Nothing Selected" S LREND=1
  1.  Q
  1. QUE ;
  1.  S ZTRTN="START^LRLNCPMP"
  1.  S ZTDESC="LAB TESTS MAP REPORT",ZTSAVE("LRMAP*")=""
  1.  D ^%ZTLOAD
  1.  I $D(ZTSK)'[0 W !,"REQUEST QUEUED ",ION
  1.  D HOME^%ZIS K IO("Q") Q
  1. START ;BEGINS REPORT
  1.  N LOINCDTA,LOINCDTB,LOINCTAS,LRAA,LRAA1,LRPNTA,LRPNTB
  1.  N LINE
  1.  S LINE=0
  1.  D INI
  1.  I LRMAP'=2 D EN1
  1.  I LRMAP=2 D
  1.  . S LRIEN=0 F  S LRIEN=$O(LRMAP(LRIEN)) Q:LRIEN<1  S LRNODE=$G(^LAB(60,LRIEN,0)) D YMAP
  1.  D YMAPPRT,EXIT
  1.  Q
  1. EN1 ;PRINT MAPPED OR NOT MAPPED LAB TESTS IF THERE IS A DATA NAME 
  1.  S LRTEST=""
  1.  S LRTST="^LAB(60,""B"",0)"
  1.  F  S LRTST=$Q(@LRTST) Q:$QS(LRTST,2)'="B"  D  Q:$G(LREND)
  1.  . Q:$G(@LRTST)
  1.  . S LRIEN=$QS(LRTST,4)
  1.  . Q:'$D(^LAB(60,LRIEN,0))#2  S LRNODE=^(0)
  1.  . I $S($P(LRNODE,U,3)="":1,$P(LRNODE,U,3)="N":1,'$P($P(LRNODE,U,5),";",2):1,1:0) Q
  1.  .;----- BEGIN IHS MODIFCATIONS LR*5.2*1018
  1.  .D BLRLOINC  ;SEARCH FOR IHS LOINC ENTRIES
  1.  .Q
  1.  .;----- END IHS MODIFICATIONS
  1.  . N LRNLT
  1.  . S LRNLT=+$P($G(^LAB(60,LRIEN,64)),U,2)
  1.  . I 'LRMAP,$S(('$D(^LAM("AL",LRIEN))&('$D(^LAM("AM",LRIEN)))):1,1:0) D NMAP
  1.  . I LRMAP,$S($D(^LAM("AL",LRIEN)):1,$D(^LAM("AM",LRIEN)):1,1:0) D YMAP
  1.  Q
  1. YMAPPRT I $D(^TMP($J,"LRDATA")) D
  1.  . S LRPRT=0
  1.  . F  S LRPRT=$O(^TMP($J,"LRDATA",LRPRT)) Q:LRPRT=""  D  Q:$G(LREND)
  1.  .. I $Y+4>IOSL D HDR Q:$G(LREND)
  1.  .. W !,^TMP($J,"LRDATA",LRPRT)
  1.  Q
  1. NMAP ;
  1.  I $Y+4>IOSL D HDR Q:$G(LREND)
  1.  S LRTESTN=$P(LRNODE,U)
  1.  W !,?1,LRTESTN
  1.  S LRNLT=$P($G(^LAB(60,LRIEN,64)),U,2)
  1.  I LRNLT D
  1.  . N LROUT
  1.  . D GETS^DIQ(64,LRNLT_",",".01;1","E","LROUT")
  1.  . W !?5,$G(LROUT(64,LRNLT_",",1,"E")),?18,$G(LROUT(64,LRNLT_",",.01,"E"))
  1.  W !
  1.  Q
  1. YMAP ;
  1.  S LINE=$G(LINE)+1
  1.  S ^TMP($J,"LRDATA",LINE)="LAB TEST :  "_$P(LRNODE,U),LINE=LINE+1
  1.  N LRA,LRNLTX
  1.  S LRNLT=0
  1.  F  S LRNLT=$O(^LAM("AM",LRIEN,LRNLT)) Q:LRNLT=""  I '$D(LRNLTX(LRNLT)) D
  1.  . S LRA=LRNLT,LRNLTX(LRNLT)=1
  1.  . D LOINCLA^LRSRVR
  1.  S LRNLT=0
  1.  F  S LRNLT=$O(^LAM("AL",LRIEN,LRNLT)) Q:LRNLT=""  I '$D(LRNLTX(LRNLT)) D
  1.  . S LRA=LRNLT,LRNLTX(LRNLT)=1
  1.  . D LOINCLA^LRSRVR
  1.  S LINE=$G(LINE)+1,^TMP($J,"LRDATA",LINE)="-------------------"
  1.  S LINE=LINE+1,^TMP($J,"LRDATA",LINE)="",LINE=LINE+1
  1.  Q
  1. INI ;INITIALIZE VARIABLES
  1.  K ^TMP($J,"LRDATA")
  1.  S (LREND,LRPAGE)=0,$P(LRLINE,"=",(IOM-1))=""
  1.  S LRPDT=$$FMTE^XLFDT($$NOW^XLFDT,"Z5M")
  1. HDR ;PRINT HEADING
  1.  I LRPAGE,$E(IOST,1,2)="C-" W !,"Press RETURN to continue or '^' to exit: " R N:DTIME S LREND='$T!(N="^") Q:LREND
  1.  S LRPAGE=LRPAGE+1 W @IOF
  1.  ;PRINT HEADING
  1.  W !?16,"LAB TESTS"_$S(LRMAP=2:" Individual Mapped",LRMAP=1:" Mapped",LRMAP'=1:" NOT Mapped",1:0)_" TO LOINC CODES"
  1.  W !?5,LRPDT,?(IOM-15)," Page ",$J(LRPAGE,3)
  1.  ;I 'LRMAP W !?5,"LAB TEST"
  1.  ;I 'LRMAP W !,?10,"RESULT NLT"
  1.  I LRMAP=1 W !!?5,"LAB TEST",?37,"SPECIMEN",?67,"LOINC CODE"
  1.  I LRMAP=0 W !!?5,"LAB TEST",?37,"SPECIMEN"
  1.  W !,LRLINE,!
  1.  Q
  1. EXIT I $E(IOST,1,2)="P-" W @IOF
  1.  S:$D(ZTQUEUED) ZTREQ="@"
  1.  Q:$G(LRDBUG)
  1.  K DIR,DIRUT,LREND,LRPAGE,I,J,LRA,LRLOC,LRIEN,LRPREV,ZTIO,ZTDESC,ZTRTN
  1.  K LRMAP,LRSPEC,LRTEST,LRTESTN,LRLOINC,LRPDT,LRLINE,LRX,DUOUT,ZTSAVE
  1.  K LRNLT,LRNLTN,LRNODE,LRPRT,LRSPECN,LRTST,N,Y,POP,ZTSK,ZTQUEUED,ZTREQ
  1.  K ^TMP($J,"LRDATA")
  1.  Q
  1.  ;IHS LOINC REPORT
  1. BLRLOINC ;
  1.  S LRTEST=$P(LRNODE,U)
  1.  S LRX=0
  1.  F  S LRX=$O(^LAB(60,LRIEN,1,LRX)) Q:'LRX  D  Q:$G(LREND)
  1.  .S BLRLOINC=+$G(^LAB(60,LRIEN,1,LRX,95.3))
  1.  .I $G(LRMAP)=0,BLRLOINC'=0 Q
  1.  .I $G(LRMAP)=1,BLRLOINC=0 Q
  1.  .S LRSPEC=$P($G(^LAB(61,LRX,0)),U)
  1.  .;S LRTEST=$P($G(^LAB(60,LRIEN,0)),U)
  1.  .I $Y+4>IOSL D HDR Q:$G(LREND)
  1.  .W !?1,LRTEST,?37,$E(LRSPEC,1,30) I $G(LRMAP)=1 W ?67,BLRLOINC,!,$G(^LAB(95.3,BLRLOINC,80)),!
  1.  Q