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 ---[H[J[2J[HLRSORA2 3921 printed Dec 13, 2024@02:20:28 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
