- LRSORC1A ;VA/DALISC/DRH - LRSORC Continued ;07-22-93
- ;;5.2;LAB SERVICE;**1031**;NOV 1, 1997
- ;
- ;;VA LR Patch(s): 201,344,351,384
- ;
- INIT ;
- S U="^"
- D CONTROL
- Q
- CONTROL ;
- D SORT
- Q
- SORT ;
- W:$E(IOST,1,2)="C-" @IOF
- W:$E(IOST,1,2)="P-" !
- D HDR
- D PRINT
- D:'LREND SUMMARY
- D END
- Q
- SUMMARY ;
- I ($Y>(IOSL-7)) D:$E(IOST,1,2)="C-" WAIT Q:LREND W @IOF D HDR
- F I=$Y:1:(IOSL-6) W !
- W ?20,"END OF SPECIAL REPORT"
- Q
- END ;
- D:($E(IOST,1,2)="C-")&('LREND) WAIT
- W @IOF D:'$D(ZTQUEUED) ^%ZISC
- K ^TMP("LR",$J)
- K ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK,ZTQUEUED,%ZIS,POP,%H,%DT,DTOUT,DUOUT
- K DIR,DIC,I,T,C,X,Y,L0,SEX,AGE,DFN,DOB,PNM,SSN,VA("BID"),VA("PID"),VAERR
- K LRAA,LRAD,LRDFN,LRDPF,LREND,LRFAN,LRIDT,LRLAN,LRLCS,LRSUB1,LRSUB2
- K LRLLOC,LRTX,LRTST,LRTVAL,LRCRTFLG,LRAN,LRSRT,LRPAG,LRDATE,LRDASH,LRDAT
- K LRLOC,LRPTS,LREDT,LRPDT,LRSDT,LRTREC,LRPREC,LREDAT,LRSDAT,LRSPDAT
- K LRWRD,LRHDR2,LRSUB3,LRAAA
- K HRCN ;IHS/ANMC/CLS 08/18/96
- Q
- PRINT ;
- S LRSUB1=""
- I $O(^TMP("LR",$J,LRSUB1))="" W !!?30,"NO MATCHING DATA FOUND",!! Q
- F S LRSUB1=$O(^TMP("LR",$J,LRSUB1)) Q:(LRSUB1="")!(LREND) D
- .S LRSUB2=""
- .F S LRSUB2=$O(^TMP("LR",$J,LRSUB1,LRSUB2)) Q:(LRSUB2="")!(LREND) D
- ..S LRSUB3=""
- ..F S LRSUB3=$O(^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3)) Q:(LRSUB3="")!(LREND) D
- ...S LRAN=""
- ...F S LRAN=$O(^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN)) Q:(LRAN="")!(LREND) D
- ....S LRPREC=^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN)
- ....S LRDPF=$P(LRPREC,U,4)
- ....; S PNM=$P(LRPREC,U),SSN=$P(LRPREC,U,2),LRLOC=$P(LRPREC,U,3)
- ....S PNM=$P(LRPREC,U),HRCN=$P(LRPREC,U,2),LRLOC=$P(LRPREC,U,3) ;IHS/ANMC/CLS 08/18/96
- ....S LRSPEC=$P(^LAB(61,$P(LRPREC,U,6),0),U)
- ....S LRSPNUM=$P(LRPREC,U,6)
- ....S LRSPDAT=$P(LRPREC,U,5)
- ....I ($Y>(IOSL-8)) D:$E(IOST,1,2)="C-" WAIT Q:LREND W @IOF D HDR
- ....;S PNM1=$P(PNM,","),PNM2=$P(PNM,",",2)
- ....;S LRCHNG=PNM1 D CHNCASE^LRSORA2 S PNM1=LRCHNG
- ....;S LRCHNG=PNM2 D CHNCASE^LRSORA2 S PNM2=LRCHNG
- ....;S PNM=PNM1_","_PNM2
- ....;S LRCHNG=LRSPEC D CHNCASE^LRSORA2 S LRSPEC=LRCHNG
- ....; W !,$E(PNM,1,22),?23,$E(SSN,1,11) W:LRDPF=2 ?35,$E(LRLOC,1,12),?48,$E(LRAN,1,14)
- ....W !,$E(PNM,1,23),?25,HRCN W:LRDPF=2 " ",LRLOC,?50,$E(LRAN,1,14) ;IHS/ANMC/CLS 08/18/96
- ....W ?63,LRSPDAT
- ....W !," ",LRSPEC
- ....D PRNTST
- Q
- PRNTST ;
- N LRRLO,LRRHI,LRCLO,LRCHI,LRTLO,LRTHI,LRFLAG,VAR
- S I=""
- F S I=$O(^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN,"TST",I)) Q:(I="")!(LREND) D
- .S LRTREC=^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN,"TST",I)
- .S LRTST=$P(LRTREC,U),LRTVAL=$P(LRTREC,U,2),LRCRTFLG=$P(LRTREC,U,3)
- .I ($Y>(IOSL-7)) D
- ..D CONT D:$E(IOST,1,2)="C-" WAIT Q:LREND
- ..W @IOF D HDR
- ..; W !,$E(PNM,1,22),?23,$E(SSN,1,11) W:LRDPF=2 ?35,$E(LRLOC,1,12),?48,$E(LRAN,1,14)
- ..W !,$E(PNM,1,23),?25,HRCN W:LRDPF=2 " ",LRLOC,?50,$E(LRAN,1,14) ;IHS/ANMC/CLS 08/18/96
- ..W ?63,LRSPDAT
- .Q:LREND
- .S LRTX=$P(LRTREC,U,5)
- .S LRFLAG=$P(LRTREC,U,6)
- .S LRREF=$G(^LAB(60,LRTX,1,LRSPNUM,0))
- .; set ranges LRFLAG on - from file 63 LRFLAG off - from file 60
- .S LRRLO=$S(LRFLAG:$P(LRTREC,U,7),1:$P(LRREF,U,2))
- .S LRRHI=$S(LRFLAG:$P(LRTREC,U,8),1:$P(LRREF,U,3))
- .S LRCLO=$S(LRFLAG:$P(LRTREC,U,9),1:$P(LRREF,U,4))
- .S LRCHI=$S(LRFLAG:$P(LRTREC,U,10),1:$P(LRREF,U,5))
- .S LRTLO=$S(LRFLAG:$P(LRTREC,U,11),1:$P(LRREF,U,11))
- .S LRTHI=$S(LRFLAG:$P(LRTREC,U,12),1:$P(LRREF,U,12))
- .F VAR="LRRLO","LRRHI","LRCLO","LRCHI" I @VAR="" S @VAR="none"
- .;
- .S LRTST=$P($G(^LAB(60,LRTX,.1)),U)
- .I LRTST="" S LRTST=$E($P(^LAB(60,LRTX,0),U),1,10)
- .;I 'LRTST S LRTST=$E($P(^LAB(60,LRTX,0),U),1,10)
- .;S LRCHNG=LRTST D CHNCASE^LRSORA2 S LRTST=LRCHNG
- .W !,?2,$E(LRTST,1,9),?12,$J(LRTVAL,6)
- .W ?19,$E($P(LRREF,U,7),1,10),?28,LRCRTFLG
- . I 'LRTLO,('LRTHI) D RANGE
- . I LRTLO W ?32,"Ther: ",LRTLO,"-"
- . I LRTHI W LRTHI D CRITICL
- I '$O(^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",0)) W !
- E D COM
- Q
- COM ;Print comments on specimen
- W !,"COMMENT(S): "
- S C=""
- F S C=$O(^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",C)) Q:(C="")!(LREND) D
- .I ($Y>(IOSL-7)) D
- ..D CONT D:$E(IOST,1,2)="C-" WAIT Q:LREND
- ..W @IOF D HDR
- ..; W !,$E(PNM,1,22),?23,$E(SSN,1,11) W:LRDPF=2 ?35,$E(LRLOC,1,12),?48,$E(LRAN,1,14)
- ..W !,$E(PNM,1,23),?25,HRCN W:LRDPF=2 " ",LRLOC,?50,$E(LRAN,1,14) ;IHS/ANMC/CLS 08/18/96
- ..W ?63,LRSPDAT
- ..;W !,PNM,?35,SSN W:LRDPF=2 " ",LRLOC,?60,LRAN
- ..;D HDR
- ..W !,"COMMENT(S): "
- .Q:LREND
- .W ?12,^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",C),!
- Q
- HDR ;
- S LRPAG=LRPAG+1
- ; W "SPECIAL REPORT: SEARCHING FOR CRITICAL FLAGS "
- ; W LRDATE,?65,"Pg ",LRPAG,!,LRHDR2,!
- ;
- ; ----- BEGIN IHS/OIT/MKK LR*5.2*1025 MODIFICATION
- D LABHDR^BLRUTIL2 ; Institution Name & Address in Header
- NEW STR,PGLEN
- S STR=$$CJ^XLFSTR("SPECIAL REPORT: SEARCHING FOR CRITICAL FLAGS",IOM)
- S PGLEN=$L("Pg "_LRPAG)
- S $E(STR,IOM-(PGLEN+2))="Pg "_LRPAG
- S STR=$$TRIM^XLFSTR(STR,"R"," ") ; Trim trailing spaces
- ;
- W STR,!,$$CJ^XLFSTR(LRHDR2,IOM),!
- W $$CJ^XLFSTR("Print Date: "_$$HTE^XLFDT($H,"2DZ"),IOM),!
- ; ----- END IHS/OIT/MKK LR*5.2*1025 MODIFICATION
- ;
- D LRGLIN^LRX
- Q
- RANGE ;
- W ?31,"Ref. Range: ",LRRLO,"-",LRRHI
- D CRITICL
- Q
- CRITICL ;
- W ?57,"Critical: ",LRCLO,"-",LRCHI
- Q
- WAIT ;
- K DIR S DIR(0)="E" D ^DIR
- S:($D(DTOUT))!($D(DUOUT)) LREND=1
- Q
- CONT W !?10,"CONTINUED NEXT PAGE",! Q
- LRSORC1A ;VA/DALISC/DRH - LRSORC Continued ;07-22-93
- +1 ;;5.2;LAB SERVICE;**1031**;NOV 1, 1997
- +2 ;
- +3 ;;VA LR Patch(s): 201,344,351,384
- +4 ;
- INIT ;
- +1 SET U="^"
- +2 DO CONTROL
- +3 QUIT
- CONTROL ;
- +1 DO SORT
- +2 QUIT
- SORT ;
- +1 IF $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- +2 IF $EXTRACT(IOST,1,2)="P-"
- WRITE !
- +3 DO HDR
- +4 DO PRINT
- +5 IF 'LREND
- DO SUMMARY
- +6 DO END
- +7 QUIT
- SUMMARY ;
- +1 IF ($Y>(IOSL-7))
- IF $EXTRACT(IOST,1,2)="C-"
- DO WAIT
- IF LREND
- QUIT
- WRITE @IOF
- DO HDR
- +2 FOR I=$Y:1:(IOSL-6)
- WRITE !
- +3 WRITE ?20,"END OF SPECIAL REPORT"
- +4 QUIT
- END ;
- +1 IF ($EXTRACT(IOST,1,2)="C-")&('LREND)
- DO WAIT
- +2 WRITE @IOF
- IF '$DATA(ZTQUEUED)
- DO ^%ZISC
- +3 KILL ^TMP("LR",$JOB)
- +4 KILL ZTRTN,ZTIO,ZTDESC,ZTSAVE,ZTSK,ZTQUEUED,%ZIS,POP,%H,%DT,DTOUT,DUOUT
- +5 KILL DIR,DIC,I,T,C,X,Y,L0,SEX,AGE,DFN,DOB,PNM,SSN,VA("BID"),VA("PID"),VAERR
- +6 KILL LRAA,LRAD,LRDFN,LRDPF,LREND,LRFAN,LRIDT,LRLAN,LRLCS,LRSUB1,LRSUB2
- +7 KILL LRLLOC,LRTX,LRTST,LRTVAL,LRCRTFLG,LRAN,LRSRT,LRPAG,LRDATE,LRDASH,LRDAT
- +8 KILL LRLOC,LRPTS,LREDT,LRPDT,LRSDT,LRTREC,LRPREC,LREDAT,LRSDAT,LRSPDAT
- +9 KILL LRWRD,LRHDR2,LRSUB3,LRAAA
- +10 ;IHS/ANMC/CLS 08/18/96
- KILL HRCN
- +11 QUIT
- PRINT ;
- +1 SET LRSUB1=""
- +2 IF $ORDER(^TMP("LR",$JOB,LRSUB1))=""
- WRITE !!?30,"NO MATCHING DATA FOUND",!!
- QUIT
- +3 FOR
- SET LRSUB1=$ORDER(^TMP("LR",$JOB,LRSUB1))
- IF (LRSUB1="")!(LREND)
- QUIT
- Begin DoDot:1
- +4 SET LRSUB2=""
- +5 FOR
- SET LRSUB2=$ORDER(^TMP("LR",$JOB,LRSUB1,LRSUB2))
- IF (LRSUB2="")!(LREND)
- QUIT
- Begin DoDot:2
- +6 SET LRSUB3=""
- +7 FOR
- SET LRSUB3=$ORDER(^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3))
- IF (LRSUB3="")!(LREND)
- QUIT
- Begin DoDot:3
- +8 SET LRAN=""
- +9 FOR
- SET LRAN=$ORDER(^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN))
- IF (LRAN="")!(LREND)
- QUIT
- Begin DoDot:4
- +10 SET LRPREC=^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN)
- +11 SET LRDPF=$PIECE(LRPREC,U,4)
- +12 ; S PNM=$P(LRPREC,U),SSN=$P(LRPREC,U,2),LRLOC=$P(LRPREC,U,3)
- +13 ;IHS/ANMC/CLS 08/18/96
- SET PNM=$PIECE(LRPREC,U)
- SET HRCN=$PIECE(LRPREC,U,2)
- SET LRLOC=$PIECE(LRPREC,U,3)
- +14 SET LRSPEC=$PIECE(^LAB(61,$PIECE(LRPREC,U,6),0),U)
- +15 SET LRSPNUM=$PIECE(LRPREC,U,6)
- +16 SET LRSPDAT=$PIECE(LRPREC,U,5)
- +17 IF ($Y>(IOSL-8))
- IF $EXTRACT(IOST,1,2)="C-"
- DO WAIT
- IF LREND
- QUIT
- WRITE @IOF
- DO HDR
- +18 ;S PNM1=$P(PNM,","),PNM2=$P(PNM,",",2)
- +19 ;S LRCHNG=PNM1 D CHNCASE^LRSORA2 S PNM1=LRCHNG
- +20 ;S LRCHNG=PNM2 D CHNCASE^LRSORA2 S PNM2=LRCHNG
- +21 ;S PNM=PNM1_","_PNM2
- +22 ;S LRCHNG=LRSPEC D CHNCASE^LRSORA2 S LRSPEC=LRCHNG
- +23 ; W !,$E(PNM,1,22),?23,$E(SSN,1,11) W:LRDPF=2 ?35,$E(LRLOC,1,12),?48,$E(LRAN,1,14)
- +24 ;IHS/ANMC/CLS 08/18/96
- WRITE !,$EXTRACT(PNM,1,23),?25,HRCN
- IF LRDPF=2
- WRITE " ",LRLOC,?50,$EXTRACT(LRAN,1,14)
- +25 WRITE ?63,LRSPDAT
- +26 WRITE !," ",LRSPEC
- +27 DO PRNTST
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +28 QUIT
- PRNTST ;
- +1 NEW LRRLO,LRRHI,LRCLO,LRCHI,LRTLO,LRTHI,LRFLAG,VAR
- +2 SET I=""
- +3 FOR
- SET I=$ORDER(^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"TST",I))
- IF (I="")!(LREND)
- QUIT
- Begin DoDot:1
- +4 SET LRTREC=^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"TST",I)
- +5 SET LRTST=$PIECE(LRTREC,U)
- SET LRTVAL=$PIECE(LRTREC,U,2)
- SET LRCRTFLG=$PIECE(LRTREC,U,3)
- +6 IF ($Y>(IOSL-7))
- Begin DoDot:2
- +7 DO CONT
- IF $EXTRACT(IOST,1,2)="C-"
- DO WAIT
- IF LREND
- QUIT
- +8 WRITE @IOF
- DO HDR
- +9 ; W !,$E(PNM,1,22),?23,$E(SSN,1,11) W:LRDPF=2 ?35,$E(LRLOC,1,12),?48,$E(LRAN,1,14)
- +10 ;IHS/ANMC/CLS 08/18/96
- WRITE !,$EXTRACT(PNM,1,23),?25,HRCN
- IF LRDPF=2
- WRITE " ",LRLOC,?50,$EXTRACT(LRAN,1,14)
- +11 WRITE ?63,LRSPDAT
- End DoDot:2
- +12 IF LREND
- QUIT
- +13 SET LRTX=$PIECE(LRTREC,U,5)
- +14 SET LRFLAG=$PIECE(LRTREC,U,6)
- +15 SET LRREF=$GET(^LAB(60,LRTX,1,LRSPNUM,0))
- +16 ; set ranges LRFLAG on - from file 63 LRFLAG off - from file 60
- +17 SET LRRLO=$SELECT(LRFLAG:$PIECE(LRTREC,U,7),1:$PIECE(LRREF,U,2))
- +18 SET LRRHI=$SELECT(LRFLAG:$PIECE(LRTREC,U,8),1:$PIECE(LRREF,U,3))
- +19 SET LRCLO=$SELECT(LRFLAG:$PIECE(LRTREC,U,9),1:$PIECE(LRREF,U,4))
- +20 SET LRCHI=$SELECT(LRFLAG:$PIECE(LRTREC,U,10),1:$PIECE(LRREF,U,5))
- +21 SET LRTLO=$SELECT(LRFLAG:$PIECE(LRTREC,U,11),1:$PIECE(LRREF,U,11))
- +22 SET LRTHI=$SELECT(LRFLAG:$PIECE(LRTREC,U,12),1:$PIECE(LRREF,U,12))
- +23 FOR VAR="LRRLO","LRRHI","LRCLO","LRCHI"
- IF @VAR=""
- SET @VAR="none"
- +24 ;
- +25 SET LRTST=$PIECE($GET(^LAB(60,LRTX,.1)),U)
- +26 IF LRTST=""
- SET LRTST=$EXTRACT($PIECE(^LAB(60,LRTX,0),U),1,10)
- +27 ;I 'LRTST S LRTST=$E($P(^LAB(60,LRTX,0),U),1,10)
- +28 ;S LRCHNG=LRTST D CHNCASE^LRSORA2 S LRTST=LRCHNG
- +29 WRITE !,?2,$EXTRACT(LRTST,1,9),?12,$JUSTIFY(LRTVAL,6)
- +30 WRITE ?19,$EXTRACT($PIECE(LRREF,U,7),1,10),?28,LRCRTFLG
- +31 IF 'LRTLO
- IF ('LRTHI)
- DO RANGE
- +32 IF LRTLO
- WRITE ?32,"Ther: ",LRTLO,"-"
- +33 IF LRTHI
- WRITE LRTHI
- DO CRITICL
- End DoDot:1
- +34 IF '$ORDER(^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",0))
- WRITE !
- +35 IF '$TEST
- DO COM
- +36 QUIT
- COM ;Print comments on specimen
- +1 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>(IOSL-7))
- Begin DoDot:2
- +5 DO CONT
- IF $EXTRACT(IOST,1,2)="C-"
- DO WAIT
- IF LREND
- QUIT
- +6 WRITE @IOF
- DO HDR
- +7 ; W !,$E(PNM,1,22),?23,$E(SSN,1,11) W:LRDPF=2 ?35,$E(LRLOC,1,12),?48,$E(LRAN,1,14)
- +8 ;IHS/ANMC/CLS 08/18/96
- WRITE !,$EXTRACT(PNM,1,23),?25,HRCN
- IF LRDPF=2
- WRITE " ",LRLOC,?50,$EXTRACT(LRAN,1,14)
- +9 WRITE ?63,LRSPDAT
- +10 ;W !,PNM,?35,SSN W:LRDPF=2 " ",LRLOC,?60,LRAN
- +11 ;D HDR
- +12 WRITE !,"COMMENT(S): "
- End DoDot:2
- +13 IF LREND
- QUIT
- +14 WRITE ?12,^TMP("LR",$JOB,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",C),!
- End DoDot:1
- +15 QUIT
- HDR ;
- +1 SET LRPAG=LRPAG+1
- +2 ; W "SPECIAL REPORT: SEARCHING FOR CRITICAL FLAGS "
- +3 ; W LRDATE,?65,"Pg ",LRPAG,!,LRHDR2,!
- +4 ;
- +5 ; ----- BEGIN IHS/OIT/MKK LR*5.2*1025 MODIFICATION
- +6 ; Institution Name & Address in Header
- DO LABHDR^BLRUTIL2
- +7 NEW STR,PGLEN
- +8 SET STR=$$CJ^XLFSTR("SPECIAL REPORT: SEARCHING FOR CRITICAL FLAGS",IOM)
- +9 SET PGLEN=$LENGTH("Pg "_LRPAG)
- +10 SET $EXTRACT(STR,IOM-(PGLEN+2))="Pg "_LRPAG
- +11 ; Trim trailing spaces
- SET STR=$$TRIM^XLFSTR(STR,"R"," ")
- +12 ;
- +13 WRITE STR,!,$$CJ^XLFSTR(LRHDR2,IOM),!
- +14 WRITE $$CJ^XLFSTR("Print Date: "_$$HTE^XLFDT($HOROLOG,"2DZ"),IOM),!
- +15 ; ----- END IHS/OIT/MKK LR*5.2*1025 MODIFICATION
- +16 ;
- +17 DO LRGLIN^LRX
- +18 QUIT
- RANGE ;
- +1 WRITE ?31,"Ref. Range: ",LRRLO,"-",LRRHI
- +2 DO CRITICL
- +3 QUIT
- CRITICL ;
- +1 WRITE ?57,"Critical: ",LRCLO,"-",LRCHI
- +2 QUIT
- WAIT ;
- +1 KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- +2 IF ($DATA(DTOUT))!($DATA(DUOUT))
- SET LREND=1
- +3 QUIT
- CONT WRITE !?10,"CONTINUED NEXT PAGE",!
- QUIT
