source: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRLNCTOP.m@ 636

LRLNCTOP ;DALOI/RH-LEDI HL7 CODES ;11-OCT-1998
 ;;5.2;LAB SERVICE;**215,232**;Sep 27,1994
EN ;
 W @IOF
 W !,$$CJ^XLFSTR("This option prints a list of SITE/SPECIMENS from the LABORATORY TEST FILE",IOM)
 W !,$$CJ^XLFSTR(" Standard LEDI HL7 specimen codes in the Topography file.",IOM)
 W !,$$CJ^XLFSTR("You will be prompted to print the specimen with or without the LEDI HL7 codes; ",IOM)
WHICH ;
 W !!
 W !,"Print Topography with or without a LEDI HL7 CODE and Time Aspect."
 K DIR S DIR("?")="Print Topography with or without a LEDI HL7 CODE and Time Aspect"
 S DIR(0)="S^1:WITH;2:WITHOUT" D ^DIR K DIR
 S LRANS=Y
 I $D(DIRUT) G EXIT Q
 K %ZIS S %ZIS="Q" D ^%ZIS G:POP EXIT
 I $D(IO("Q")) D QUE Q
 U IO D START,^%ZISC Q
QUE ;
 S ZTRTN="START^LRLNCTOP",ZTDESC="TOPOGRAPHY REPORT"
 S ZTSAVE("LRANS")=""
 D ^%ZTLOAD
 I $D(ZTSK)'[0 W !,"REQUEST QUEUED TO ",ION
 D HOME^%ZIS K IO("Q") Q
START ;BEGINS PRINTING THE REPORT
 I LRANS=1 D ALPHA
 I LRANS=2 D EN2
 D EXIT
 Q
ALPHA ;PRINTS THE ALPHABETIC LISTING OF SPECIMEN THAT HAVE A LEDI HL7 CODE IN THE TOPOGRAPHY FILE
 D INI,HDR1,EQUALS^LRX
 S LRTOP="^LAB(61,""B"",0)"
 F  S LRTOP=$Q(@LRTOP) Q:$QS(LRTOP,2)'="B"  Q:$G(LREND)  D
 . I $G(@LRTOP)!($G(LREND)) Q
 . S LRIEN=+$QS(LRTOP,4)
 . S LRY=$G(^LAB(61,LRIEN,0)) Q:'$L(LRY)
 . I $Y+4>IOSL D HDR D:'LREND HDR1,EQUALS^LRX Q:$G(LREND)
 . Q:'$P($G(^LAB(61,LRIEN,0)),U,9)!('$P($G(^LAB(61,LRIEN,0)),U,10))
 . W !?3,"[",$J(LRIEN,4),"]",?11,$E($P(LRY,U),1,20)
 . S LRIEN=$P(LRY,U,9) Q:'$D(^LAB(64.061,LRIEN,0))#2
 . W ?33,$E($P(^LAB(64.061,LRIEN,0),U),1,20)_"|"_$$GET1^DIQ(64.061,+$P(LRY,U,10),1)
 Q
EN2 ;PRINTS THE SPECIMEN THAT DO NOT HAVE A LEDI HL7 CODE
 D INI,HDR2,EQUALS^LRX
 S LRNODE="^LAB(60,""B"",0)"
 F  S LRNODE=$Q(@LRNODE) Q:$QS(LRNODE,2)'="B"  Q:$G(LREND)  D
 . I $G(@LRNODE)!($G(LREND)) Q
 . S LRI=+$QS(LRNODE,4)
 . S LRX=$G(^LAB(60,LRI,0)) Q:'$L($P(LRX,U))!($P(LRX,U,3)="")!($P(LRX,U,3)="N")
 . S LRIEN=0 F  S LRIEN=$O(^LAB(60,LRI,1,LRIEN)) Q:LRIEN<1!$G(LREND)  D
 .. S LRY=$G(^LAB(61,LRIEN,0)) Q:$P(LRY,U)=""
 .. I $P(LRY,U,9) Q
 .. I $Y+5>IOSL D HDR D:'LREND HDR2,EQUALS^LRX Q:$G(LREND)
 .. W !
 .. W:LRTEST'=$P(LRX,U) ?5,$P(LRX,U)
 .. W ?37,$E($P(LRY,U),1,30)
 .. S LRTEST=$P(LRX,U)
 Q
INI ;INITIALIZE VARIABLES
 S (LREND,LRPAGE)=0,LRTEST="" W:$E(IOST,1,2)="C-" @IOF
HDR ;PRINT HEADING
 I LRPAGE,$E(IOST,1,2)="C-" W !,"Press RETURN to continue or '^' to exit: " R LRN:DTIME S LREND='$T!(LRN="^") Q:LREND
 S LRPAGE=LRPAGE+1
 S LRDT=$$FMTE^XLFDT($$NOW^XLFDT,"Z5M")
 Q
HDR1 ;PRINT HEADING FOR SPECIMENS WITH A LEDI HL7 CODE
 W @IOF
 W !?50,LRDT,?(IOM-10)," Page ",$J(LRPAGE,3)
 W !
 W !,$$CJ^XLFSTR("A LISTING FROM THE TOPOGRAPHY FILE OF SPECIMENS WITH LEDI HL7 CODE",IOM)
 W !,$$CJ^XLFSTR("AND HAVE TIME ASPECT ENTERED",IOM)
 W !
 W !?3,"FILE 61"
 W !?4,"[IEN]",?11,"SITE/SPECIMEN",?32,"ELEC CODE NAME|TIME ASPECT"
 Q
HDR2 ;PRINT HEADING FOR TESTS WITHOUT A LEDI HL7 CODE
 W @IOF
 W !?50,LRDT,?(IOM-10)," Page ",$J(LRPAGE,3)
 W !!?23,"LAB SPECIMEN WITHOUT LEDI HL7 CODE"
 W !,$$CJ^XLFSTR("THESE SPECIMENS NEED LEDI HL7 CODES DEFINED IN THE TOPOGRAPHY FILE",IOM)
 W !!?5,"LAB TEST NAME",?37,"SITE/SPECIMEN"
 Q
EXIT ;
 S:$D(ZTQUEUED) ZTREQ="@"
 K LREND,LRPAGE,LRI,LRX,LRANS,LRY,LRDT,LRIEN,LRTEST
 K DIR,DIRUT,DUOUT,ZTIO,ZTDESC,ZTRTN,ZTSAVE
 K LRN,Y,POP,ZTSK,ZTQUEUED,ZTREQ
 Q