- LRLNCTOP ;DALOI/RH-LEDI HL7 CODES ;11-OCT-1998
- ;;5.2T9;LR;**1018**;Nov 17, 2004
- ;;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
- LRLNCTOP ;DALOI/RH-LEDI HL7 CODES ;11-OCT-1998
- +1 ;;5.2T9;LR;**1018**;Nov 17, 2004
- +2 ;;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
