source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRSORA2.m@ 1783

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**;Sep 27, 1994;Build 2
 ; 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,!
 Q
PRTEST ;
 Q:$G(LRCOMX)
 Q:$G(LREND)
 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