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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLNCTOP 3362 printed Nov 22, 2024@17:26:47 Page 2
LRLNCTOP ;DALOI/RH-LEDI HL7 CODES ;11-OCT-1998
+1 ;;5.2;LAB SERVICE;**215,232**;Sep 27,1994
EN ;
+1 WRITE @IOF
+2 WRITE !,$$CJ^XLFSTR("This option prints a list of SITE/SPECIMENS from the LABORATORY TEST FILE",IOM)
+3 WRITE !,$$CJ^XLFSTR(" Standard LEDI HL7 specimen codes in the Topography file.",IOM)
+4 WRITE !,$$CJ^XLFSTR("You will be prompted to print the specimen with or without the LEDI HL7 codes; ",IOM)
WHICH ;
+1 WRITE !!
+2 WRITE !,"Print Topography with or without a LEDI HL7 CODE and Time Aspect."
+3 KILL DIR
SET DIR("?")="Print Topography with or without a LEDI HL7 CODE and Time Aspect"
+4 SET DIR(0)="S^1:WITH;2:WITHOUT"
DO ^DIR
KILL DIR
+5 SET LRANS=Y
+6 IF $DATA(DIRUT)
GOTO EXIT
QUIT
+7 KILL %ZIS
SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO EXIT
+8 IF $DATA(IO("Q"))
DO QUE
QUIT
+9 USE IO
DO START
DO ^%ZISC
QUIT
QUE ;
+1 SET ZTRTN="START^LRLNCTOP"
SET ZTDESC="TOPOGRAPHY REPORT"
+2 SET ZTSAVE("LRANS")=""
+3 DO ^%ZTLOAD
+4 IF $DATA(ZTSK)'[0
WRITE !,"REQUEST QUEUED TO ",ION
+5 DO HOME^%ZIS
KILL IO("Q")
QUIT
START ;BEGINS PRINTING THE REPORT
+1 IF LRANS=1
DO ALPHA
+2 IF LRANS=2
DO EN2
+3 DO EXIT
+4 QUIT
ALPHA ;PRINTS THE ALPHABETIC LISTING OF SPECIMEN THAT HAVE A LEDI HL7 CODE IN THE TOPOGRAPHY FILE
+1 DO INI
DO HDR1
DO EQUALS^LRX
+2 SET LRTOP="^LAB(61,""B"",0)"
+3 FOR
SET LRTOP=$QUERY(@LRTOP)
if $QSUBSCRIPT(LRTOP,2)'="B"
QUIT
if $GET(LREND)
QUIT
Begin DoDot:1
+4 IF $GET(@LRTOP)!($GET(LREND))
QUIT
+5 SET LRIEN=+$QSUBSCRIPT(LRTOP,4)
+6 SET LRY=$GET(^LAB(61,LRIEN,0))
if '$LENGTH(LRY)
QUIT
+7 IF $Y+4>IOSL
DO HDR
if 'LREND
DO HDR1
DO EQUALS^LRX
if $GET(LREND)
QUIT
+8 if '$PIECE($GET(^LAB(61,LRIEN,0)),U,9)!('$PIECE($GET(^LAB(61,LRIEN,0)),U,10))
QUIT
+9 WRITE !?3,"[",$JUSTIFY(LRIEN,4),"]",?11,$EXTRACT($PIECE(LRY,U),1,20)
+10 SET LRIEN=$PIECE(LRY,U,9)
if '$DATA(^LAB(64.061,LRIEN,0))#2
QUIT
+11 WRITE ?33,$EXTRACT($PIECE(^LAB(64.061,LRIEN,0),U),1,20)_"|"_$$GET1^DIQ(64.061,+$PIECE(LRY,U,10),1)
End DoDot:1
+12 QUIT
EN2 ;PRINTS THE SPECIMEN THAT DO NOT HAVE A LEDI HL7 CODE
+1 DO INI
DO HDR2
DO EQUALS^LRX
+2 SET LRNODE="^LAB(60,""B"",0)"
+3 FOR
SET LRNODE=$QUERY(@LRNODE)
if $QSUBSCRIPT(LRNODE,2)'="B"
QUIT
if $GET(LREND)
QUIT
Begin DoDot:1
+4 IF $GET(@LRNODE)!($GET(LREND))
QUIT
+5 SET LRI=+$QSUBSCRIPT(LRNODE,4)
+6 SET LRX=$GET(^LAB(60,LRI,0))
if '$LENGTH($PIECE(LRX,U))!($PIECE(LRX,U,3)="")!($PIECE(LRX,U,3)="N")
QUIT
+7 SET LRIEN=0
FOR
SET LRIEN=$ORDER(^LAB(60,LRI,1,LRIEN))
if LRIEN<1!$GET(LREND)
QUIT
Begin DoDot:2
+8 SET LRY=$GET(^LAB(61,LRIEN,0))
if $PIECE(LRY,U)=""
QUIT
+9 IF $PIECE(LRY,U,9)
QUIT
+10 IF $Y+5>IOSL
DO HDR
if 'LREND
DO HDR2
DO EQUALS^LRX
if $GET(LREND)
QUIT
+11 WRITE !
+12 if LRTEST'=$PIECE(LRX,U)
WRITE ?5,$PIECE(LRX,U)
+13 WRITE ?37,$EXTRACT($PIECE(LRY,U),1,30)
+14 SET LRTEST=$PIECE(LRX,U)
End DoDot:2
End DoDot:1
+15 QUIT
INI ;INITIALIZE VARIABLES
+1 SET (LREND,LRPAGE)=0
SET LRTEST=""
if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
HDR ;PRINT HEADING
+1 IF LRPAGE
IF $EXTRACT(IOST,1,2)="C-"
WRITE !,"Press RETURN to continue or '^' to exit: "
READ LRN:DTIME
SET LREND='$TEST!(LRN="^")
if LREND
QUIT
+2 SET LRPAGE=LRPAGE+1
+3 SET LRDT=$$FMTE^XLFDT($$NOW^XLFDT,"Z5M")
+4 QUIT
HDR1 ;PRINT HEADING FOR SPECIMENS WITH A LEDI HL7 CODE
+1 WRITE @IOF
+2 WRITE !?50,LRDT,?(IOM-10)," Page ",$JUSTIFY(LRPAGE,3)
+3 WRITE !
+4 WRITE !,$$CJ^XLFSTR("A LISTING FROM THE TOPOGRAPHY FILE OF SPECIMENS WITH LEDI HL7 CODE",IOM)
+5 WRITE !,$$CJ^XLFSTR("AND HAVE TIME ASPECT ENTERED",IOM)
+6 WRITE !
+7 WRITE !?3,"FILE 61"
+8 WRITE !?4,"[IEN]",?11,"SITE/SPECIMEN",?32,"ELEC CODE NAME|TIME ASPECT"
+9 QUIT
HDR2 ;PRINT HEADING FOR TESTS WITHOUT A LEDI HL7 CODE
+1 WRITE @IOF
+2 WRITE !?50,LRDT,?(IOM-10)," Page ",$JUSTIFY(LRPAGE,3)
+3 WRITE !!?23,"LAB SPECIMEN WITHOUT LEDI HL7 CODE"
+4 WRITE !,$$CJ^XLFSTR("THESE SPECIMENS NEED LEDI HL7 CODES DEFINED IN THE TOPOGRAPHY FILE",IOM)
+5 WRITE !!?5,"LAB TEST NAME",?37,"SITE/SPECIMEN"
+6 QUIT
EXIT ;
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL LREND,LRPAGE,LRI,LRX,LRANS,LRY,LRDT,LRIEN,LRTEST
+3 KILL DIR,DIRUT,DUOUT,ZTIO,ZTDESC,ZTRTN,ZTSAVE
+4 KILL LRN,Y,POP,ZTSK,ZTQUEUED,ZTREQ
+5 QUIT
