LRSORA2.m

LRSORA2 ;DALOI/KCM/DRH/RLM-SEARCH LAB DATA AND PRINT REPORT ;8/28/89  12:07

 ;;5.2;LAB SERVICE;**2,62,201,272,369,449**;Sep 27, 1994;Build 4

 ; Reference to $$FMTE^XLFDT supported by IA #10103

 ; Reference to DD^%DT supported by IA #10003

 ; Reference to ^DIR supported by IA #10026

 ; Reference to $$FMTE^XLFDT supported by IA #10103

 ; Reference to $$NOW^XLFDT supported by IA #10103

START ;

 D BUILD^LRSORA3

 S (LRTSTCK,LRSPCK,LRPATCK)="",NEWPG=1

 W:$E(IOST,1,2)="C-" @IOF

 D MAINLOOP I LREND=1 D END QUIT

 D:'LREND SUMMARY

 D END

 Q

MAINLOOP ;

 S (LROLD,LRTOP,LRSPCK,REFCK,LRTSTCK)=""

 S LRSORTI="^TMP(""LR"","_$J_")"

 F  S LRSORTI=$Q(@LRSORTI) Q:LRSORTI'[$J!(LREND=1)  D

 . D SET Q:LREND=1

 . D PRTCONT Q:LREND=1

 Q

END ;

 K DIR

 K LROLD,LRTOP,LRSPCK,REFCK,LRTSTK,LRCOMX,LRSORTI

 K LRPREC,PNM,LRCHNG,LRLO,LRHI,LRAN,LRMRK,LRWRD,LRVAL

 K LRTEST,LRPREC,LRCDT,LRUNITS,LRCOUNT,NEWPG

 Q

SET ;

 S LRCOMX=0

 I LRSORTI["""COM""" W "     COMMENT: ",@LRSORTI,! S LRCOMX=1 QUIT

 S LRPREC=@LRSORTI

 S PNM=$P(LRPREC,U),SSN=$P(LRPREC,U,2),LRLOC=$P(LRPREC,U,3)

 S LRSPEC=$P(LRPREC,U,5)

 S LRCHNG=LRSPEC D CHNCASE S LRSPEC=LRCHNG

 S LRLO=$P(LRPREC,U,7),LRHI=$P(LRPREC,U,8),LRVAL=$P(LRPREC,U,9)

 S LRMRK=$P(LRPREC,U,10),LRTHER=$P(LRPREC,U,11)

 S LRAN=$P(LRPREC,U,13),LRCDT=$P(LRPREC,U,14)

 S LRWRD=$P($G(LRPREC),U,12)

 S LRWRD=$S(""[LRWRD:"**No Entry**",1:LRWRD)

 S LRTEST=$P(LRPREC,U,15)

 S:SSN'=LROLD LROLD=SSN,LRTOP=1

 S LRUNITS=$P(LRPREC,U,16)

 S Y=LRCDT D DD^%DT S LRCDT=$E(Y,1,18)

 Q

PRTCONT ;

 Q:$G(LREND)

 S LRCOUNT=0

 D CHKPG Q:LREND=1

 I NEWPG=1 D COND1 Q

 I LRPATCK'=SSN D COND2 Q

 I LRSPCK'=LRSPEC D COND3 Q

 I LRTSTCK'=LRTEST D COND3 Q

 I LRTSTCK=LRTEST D COND4 Q

 Q

COND1 ;

 D PAGE S NEWPG=""

 D NEWPAT

 D NEWSPEC

 D NEWTST S LRCOUNT=1

 Q

COND2 ;

 D NEWPAT

 D NEWSPEC

 D NEWTST S LRCOUNT=1

 Q

COND3 ;

 D NEWSPEC

 D NEWTST S LRCOUNT=1

 Q

COND4 ;

 D NEWTST S LRCOUNT=1

 Q

PAGE ;

 W:$E(IOST,1,2)="C-" @IOF

 D HDR1 S LRTOP=1

 Q

NEWPAT ;

 D HDR2 S LRPATCK=SSN

 Q

NEWSPEC ;

 D PRSPEC S LRSPCK=LRSPEC

 Q

NEWTST ;

 D PRTEST S LRTSTCK=LRTEST

 Q

SAMETST ;

 D PRTEST

 Q

CHKPG ;

 S:LRCNT<1 LRCNT=1

 Q:$G(LREND)

 I $Y>(IOSL-7-LRCNT) S NEWPG=1 D

 .  D LEGEND W:$E(IOST,1,2)'="C-" @IOF

 .  D:$E(IOST,1,2)="C-" WAIT Q:LREND  S LRTOP=1

 Q

PRSPEC ;

 W ?2,$E(LRSPEC,1,10)

 W ?14,$S(LRTHER:"Th. Range ",1:"Ref. Range:   "),LRLO

 W "-",LRHI," ",LRUNITS,!

 S LRUNITS(1)=LRUNITS_U_LRLO_U_LRHI

 Q

PRTEST ;

 Q:$G(LRCOMX)

 Q:$G(LREND)

 I LRUNITS(1)'=($P(LRPREC,U,16)_U_$P(LRPREC,U,7)_U_$P(LRPREC,U,8)) W ! D PRSPEC

 S LRCOMX=0

 W ?4,$E(LRTEST,1,12),?14,LRAN,?30,$J(LRVAL,4)

 W ?33,LRMRK,?40,$E(LRCDT,1,6)_" "_$E($P(LRCDT,",",2),2,5)

 W " at ",$P(LRCDT,"@",2)

 W ?64,LRLOC,!

 Q:$G(LREND)!(LRTOP)

 Q

COM ;Print comments on specimen

 Q:$G(LREND)  W !," COMMENT(S): "

 S C=""

 F  S C=$O(^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",C)) Q:(C="")!(LREND)  D

 .I $Y+7>IOSL D

 ..D:$E(IOST,1,2)="C-" WAIT Q:LREND=1  D CHKPG

 ..W !,"COMMENT(S): "

 .Q:LREND

 Q

SUMMARY ;

 I ($Y>(IOSL-7-LRCNT)) D:$E(IOST,1,2)="C-" WAIT Q:LREND=1  D CHKPG

 D LEGEND

 F I=$Y:1:(IOSL-6) W !

 W !,?20,"END OF SPECIAL REPORT" QUIT

 Q

HDR1 ;

 S LRTST(0)=$E(LRTST(0),1,30)

 S %=32-$L(LRTST(0))\2+15

 S LRPAG=LRPAG+1

 W "SPECIAL REPORT",?31

 W "Report Date:   "

 W $$FMTE^XLFDT($$NOW^XLFDT,"")

 W !,LRHDR2,?71,"Pg ",$J(LRPAG,3)

 W ! D LRGLIN^LRX

 S LRTOP=""

 S LRCHKSP=0

 Q

HDR2 ;

 W !,PNM,?28,SSN,?61,$E(LRWRD,1,16),!

 Q

WAIT W ! K DIR S DIR(0)="E" D ^DIR S:($D(DUOUT))!($D(DTOUT)) LREND=1

 Q

CHNCASE ;

 S LRCHNG=$E(LRCHNG)_$$LOWCASE^LRAFUNC($E(LRCHNG,2,$L(LRCHNG)))

 Q

LEGEND ;

 D LRGLIN^LRX

 W !,"Search Criteria:"

 F %=1:1:LRTST D

 . W !,%,") " S LRCHNG=$E($P(LRTST(%,2),U,1),1,10) D CHNCASE

 . W LRCHNG," "

 . W $P(LRTST(%,2),U,3),"  Specimen: "

 . W $S($P(LRTST(%,2),U,2)'="":$E($P(LRTST(%,2),U,2),1,79-$X),1:"Any")

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRSORA2   3921     printed  Mar 13, 2025@21:24:57                                                                                                                                                                                                     Page 2

LRSORA2   ;DALOI/KCM/DRH/RLM-SEARCH LAB DATA AND PRINT REPORT ;8/28/89  12:07

 +1       ;;5.2;LAB SERVICE;**2,62,201,272,369,449**;Sep 27, 1994;Build 4

 +2       ; Reference to $$FMTE^XLFDT supported by IA #10103

 +3       ; Reference to DD^%DT supported by IA #10003

 +4       ; Reference to ^DIR supported by IA #10026

 +5       ; Reference to $$FMTE^XLFDT supported by IA #10103

 +6       ; Reference to $$NOW^XLFDT supported by IA #10103

START     ;

 +1        DO BUILD^LRSORA3

 +2        SET (LRTSTCK,LRSPCK,LRPATCK)=""

           SET NEWPG=1

 +3        if $EXTRACT(IOST,1,2)="C-"

               WRITE @IOF

 +4        DO MAINLOOP

           IF LREND=1

               DO END

               QUIT 

 +5        if 'LREND

               DO SUMMARY

 +6        DO END

 +7        QUIT 

MAINLOOP  ;

 +1        SET (LROLD,LRTOP,LRSPCK,REFCK,LRTSTCK)=""

 +2        SET LRSORTI="^TMP(""LR"","_$JOB_")"

 +3        FOR 

               SET LRSORTI=$QUERY(@LRSORTI)

               if LRSORTI'[$JOB!(LREND=1)

                   QUIT 

               Begin DoDot:1

 +4                DO SET

                   if LREND=1

                       QUIT 

 +5                DO PRTCONT

                   if LREND=1

                       QUIT 

               End DoDot:1

 +6        QUIT 

END       ;

 +1        KILL DIR

 +2        KILL LROLD,LRTOP,LRSPCK,REFCK,LRTSTK,LRCOMX,LRSORTI

 +3        KILL LRPREC,PNM,LRCHNG,LRLO,LRHI,LRAN,LRMRK,LRWRD,LRVAL

 +4        KILL LRTEST,LRPREC,LRCDT,LRUNITS,LRCOUNT,NEWPG

 +5        QUIT 

SET       ;

 +1        SET LRCOMX=0

 +2        IF LRSORTI["""COM"""

               WRITE "     COMMENT: ",@LRSORTI,!

               SET LRCOMX=1

               QUIT 

 +3        SET LRPREC=@LRSORTI

 +4        SET PNM=$PIECE(LRPREC,U)

           SET SSN=$PIECE(LRPREC,U,2)

           SET LRLOC=$PIECE(LRPREC,U,3)

 +5        SET LRSPEC=$PIECE(LRPREC,U,5)

 +6        SET LRCHNG=LRSPEC

           DO CHNCASE

           SET LRSPEC=LRCHNG

 +7        SET LRLO=$PIECE(LRPREC,U,7)

           SET LRHI=$PIECE(LRPREC,U,8)

           SET LRVAL=$PIECE(LRPREC,U,9)

 +8        SET LRMRK=$PIECE(LRPREC,U,10)

           SET LRTHER=$PIECE(LRPREC,U,11)

 +9        SET LRAN=$PIECE(LRPREC,U,13)

           SET LRCDT=$PIECE(LRPREC,U,14)

 +10       SET LRWRD=$PIECE($GET(LRPREC),U,12)

 +11       SET LRWRD=$SELECT(""[LRWRD:"**No Entry**",1:LRWRD)

 +12       SET LRTEST=$PIECE(LRPREC,U,15)

 +13       if SSN'=LROLD

               SET LROLD=SSN

               SET LRTOP=1

 +14       SET LRUNITS=$PIECE(LRPREC,U,16)

 +15       SET Y=LRCDT

           DO DD^%DT

           SET LRCDT=$EXTRACT(Y,1,18)

 +16       QUIT 

PRTCONT   ;

 +1        if $GET(LREND)

               QUIT 

 +2        SET LRCOUNT=0

 +3        DO CHKPG

           if LREND=1

               QUIT 

 +4        IF NEWPG=1

               DO COND1

               QUIT 

 +5        IF LRPATCK'=SSN

               DO COND2

               QUIT 

 +6        IF LRSPCK'=LRSPEC

               DO COND3

               QUIT 

 +7        IF LRTSTCK'=LRTEST

               DO COND3

               QUIT 

 +8        IF LRTSTCK=LRTEST

               DO COND4

               QUIT 

 +9        QUIT 

COND1     ;

 +1        DO PAGE

           SET NEWPG=""

 +2        DO NEWPAT

 +3        DO NEWSPEC

 +4        DO NEWTST

           SET LRCOUNT=1

 +5        QUIT 

COND2     ;

 +1        DO NEWPAT

 +2        DO NEWSPEC

 +3        DO NEWTST

           SET LRCOUNT=1

 +4        QUIT 

COND3     ;

 +1        DO NEWSPEC

 +2        DO NEWTST

           SET LRCOUNT=1

 +3        QUIT 

COND4     ;

 +1        DO NEWTST

           SET LRCOUNT=1

 +2        QUIT 

PAGE      ;

 +1        if $EXTRACT(IOST,1,2)="C-"

               WRITE @IOF

 +2        DO HDR1

           SET LRTOP=1

 +3        QUIT 

NEWPAT    ;

 +1        DO HDR2

           SET LRPATCK=SSN

 +2        QUIT 

NEWSPEC   ;

 +1        DO PRSPEC

           SET LRSPCK=LRSPEC

 +2        QUIT 

NEWTST    ;

 +1        DO PRTEST

           SET LRTSTCK=LRTEST

 +2        QUIT 

SAMETST   ;

 +1        DO PRTEST

 +2        QUIT 

CHKPG     ;

 +1        if LRCNT<1

               SET LRCNT=1

 +2        if $GET(LREND)

               QUIT 

 +3        IF $Y>(IOSL-7-LRCNT)

               SET NEWPG=1

               Begin DoDot:1

 +4                DO LEGEND

                   if $EXTRACT(IOST,1,2)'="C-"

                       WRITE @IOF

 +5                if $EXTRACT(IOST,1,2)="C-"

                       DO WAIT

                   if LREND

                       QUIT 

                   SET LRTOP=1

               End DoDot:1

 +6        QUIT 

PRSPEC    ;

 +1        WRITE ?2,$EXTRACT(LRSPEC,1,10)

 +2        WRITE ?14,$SELECT(LRTHER:"Th. Range ",1:"Ref. Range:   "),LRLO

 +3        WRITE "-",LRHI," ",LRUNITS,!

 +4        SET LRUNITS(1)=LRUNITS_U_LRLO_U_LRHI

 +5        QUIT 

PRTEST    ;

 +1        if $GET(LRCOMX)

               QUIT 

 +2        if $GET(LREND)

               QUIT 

 +3        IF LRUNITS(1)'=($PIECE(LRPREC,U,16)_U_$PIECE(LRPREC,U,7)_U_$PIECE(LRPREC,U,8))

               WRITE !

               DO PRSPEC

 +4        SET LRCOMX=0

 +5        WRITE ?4,$EXTRACT(LRTEST,1,12),?14,LRAN,?30,$JUSTIFY(LRVAL,4)

 +6        WRITE ?33,LRMRK,?40,$EXTRACT(LRCDT,1,6)_" "_$EXTRACT($PIECE(LRCDT,",",2),2,5)

 +7        WRITE " at ",$PIECE(LRCDT,"@",2)

 +8        WRITE ?64,LRLOC,!

 +9        if $GET(LREND)!(LRTOP)

               QUIT 

 +10       QUIT 

COM       ;Print comments on specimen

 +1        if $GET(LREND)

               QUIT 

           WRITE !," COMMENT(S): "

 +2        SET C=""

 +3        FOR 

               SET C=$ORDER(^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",C))

               if (C="")!(LREND)

                   QUIT 

               Begin DoDot:1

 +4                IF $Y+7>IOSL

                       Begin DoDot:2

 +5                        if $EXTRACT(IOST,1,2)="C-"

                               DO WAIT

                           if LREND=1

                               QUIT 

                           DO CHKPG

 +6                        WRITE !,"COMMENT(S): "

                       End DoDot:2

 +7                if LREND

                       QUIT 

               End DoDot:1

 +8        QUIT 

SUMMARY   ;

 +1        IF ($Y>(IOSL-7-LRCNT))

               if $EXTRACT(IOST,1,2)="C-"

                   DO WAIT

               if LREND=1

                   QUIT 

               DO CHKPG

 +2        DO LEGEND

 +3        FOR I=$Y:1:(IOSL-6)

               WRITE !

 +4        WRITE !,?20,"END OF SPECIAL REPORT"

           QUIT 

 +5        QUIT 

HDR1      ;

 +1        SET LRTST(0)=$EXTRACT(LRTST(0),1,30)

 +2        SET %=32-$LENGTH(LRTST(0))\2+15

 +3        SET LRPAG=LRPAG+1

 +4        WRITE "SPECIAL REPORT",?31

 +5        WRITE "Report Date:   "

 +6        WRITE $$FMTE^XLFDT($$NOW^XLFDT,"")

 +7        WRITE !,LRHDR2,?71,"Pg ",$JUSTIFY(LRPAG,3)

 +8        WRITE !

           DO LRGLIN^LRX

 +9        SET LRTOP=""

 +10       SET LRCHKSP=0

 +11       QUIT 

HDR2      ;

 +1        WRITE !,PNM,?28,SSN,?61,$EXTRACT(LRWRD,1,16),!

 +2        QUIT 

WAIT       WRITE !

           KILL DIR

           SET DIR(0)="E"

           DO ^DIR

           if ($DATA(DUOUT))!($DATA(DTOUT))

               SET LREND=1

 +1        QUIT 

CHNCASE   ;

 +1        SET LRCHNG=$EXTRACT(LRCHNG)_$$LOWCASE^LRAFUNC($EXTRACT(LRCHNG,2,$LENGTH(LRCHNG)))

 +2        QUIT 

LEGEND    ;

 +1        DO LRGLIN^LRX

 +2        WRITE !,"Search Criteria:"

 +3        FOR %=1:1:LRTST

               Begin DoDot:1

 +4                WRITE !,%,") "

                   SET LRCHNG=$EXTRACT($PIECE(LRTST(%,2),U,1),1,10)

                   DO CHNCASE

 +5                WRITE LRCHNG," "

 +6                WRITE $PIECE(LRTST(%,2),U,3),"  Specimen: "

 +7                WRITE $SELECT($PIECE(LRTST(%,2),U,2)'="":$EXTRACT($PIECE(LRTST(%,2),U,2),1,79-$X),1:"Any")

               End DoDot:1

 +8        QUIT