Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRSORA2

LRSORA2.m

Go to the documentation of this file. 
  1. LRSORA2 ;DALOI/KCM/DRH/RLM-SEARCH LAB DATA AND PRINT REPORT ;8/28/89  12:07
  1.  ;;5.2;LAB SERVICE;**1006,1018,1022,1030**;NOV 01, 1997
  1.  ;;5.2;LAB SERVICE;**2,62,201,272,369**;Sep 27, 1994;Build 2
  1.  ; Reference to $$FMTE^XLFDT supported by IA #10103
  1.  ; Reference to DD^%DT supported by IA #10003
  1.  ; Reference to ^DIR supported by IA #10026
  1.  ; Reference to $$FMTE^XLFDT supported by IA #10103
  1.  ; Reference to $$NOW^XLFDT supported by IA #10103
  1. START ;
  1.  D BUILD^LRSORA3
  1.  S (LRTSTCK,LRSPCK,LRPATCK)="",NEWPG=1
  1.  W:$E(IOST,1,2)="C-" @IOF
  1.  D MAINLOOP I LREND=1 D END QUIT
  1.  D:'LREND SUMMARY
  1.  D END
  1.  Q
  1. MAINLOOP ;
  1.  S (LROLD,LRTOP,LRSPCK,REFCK,LRTSTCK)=""
  1.  S LRSORTI="^TMP(""LR"","_$J_")"
  1.  F  S LRSORTI=$Q(@LRSORTI) Q:LRSORTI'[$J!(LREND=1)  D
  1.  . D SET Q:LREND=1
  1.  . D PRTCONT Q:LREND=1
  1.  Q
  1. END ;
  1.  K DIR
  1.  K LROLD,LRTOP,LRSPCK,REFCK,LRTSTK,LRCOMX,LRSORTI
  1.  K LRPREC,PNM,LRCHNG,LRLO,LRHI,LRAN,LRMRK,LRWRD,LRVAL
  1.  K LRTEST,LRPREC,LRCDT,LRUNITS,LRCOUNT,NEWPG
  1.  Q
  1. SET ;
  1.  S LRCOMX=0
  1.  I LRSORTI["""COM""" W "     COMMENT: ",@LRSORTI,! S LRCOMX=1 QUIT
  1.  S LRPREC=@LRSORTI
  1.  S PNM=$P(LRPREC,U),SSN=$P(LRPREC,U,2),LRLOC=$P(LRPREC,U,3)
  1.  S HRCN=$P(LRPREC,U,2)                 ; IHS/OIT/MKK -- LR*5.2*1030
  1.  S LRSPEC=$P(LRPREC,U,5)
  1.  S LRCHNG=LRSPEC D CHNCASE S LRSPEC=LRCHNG
  1.  S LRLO=$P(LRPREC,U,7),LRHI=$P(LRPREC,U,8),LRVAL=$P(LRPREC,U,9)
  1.  S LRMRK=$P(LRPREC,U,10),LRTHER=$P(LRPREC,U,11)
  1.  S LRAN=$P(LRPREC,U,13),LRCDT=$P(LRPREC,U,14)
  1.  S LRWRD=$P($G(LRPREC),U,12)
  1.  S LRWRD=$S(""[LRWRD:"**No Entry**",1:LRWRD)
  1.  S LRTEST=$P(LRPREC,U,15)
  1.  ; S:SSN'=LROLD LROLD=SSN,LRTOP=1
  1.  S:HRCN'=LROLD LROLD=HRCN,LRTOP=1        ; IHS/OIT/MKK -- LR*5.2*1030
  1.  S LRUNITS=$P(LRPREC,U,16)
  1.  S Y=LRCDT D DD^%DT S LRCDT=$E(Y,1,18)
  1.  Q
  1. PRTCONT ;
  1.  Q:$G(LREND)
  1.  S LRCOUNT=0
  1.  D CHKPG Q:LREND=1
  1.  I NEWPG=1 D COND1 Q
  1.  ; I LRPATCK'=SSN D COND2 Q
  1.  I LRPATCK'=HRCN D COND2 Q             ; IHS/OIT/MKK -- LR*5.2*1030
  1.  I LRSPCK'=LRSPEC D COND3 Q
  1.  I LRTSTCK'=LRTEST D COND3 Q
  1.  I LRTSTCK=LRTEST D COND4 Q
  1.  Q
  1. COND1 ;
  1.  D PAGE S NEWPG=""
  1.  D NEWPAT
  1.  D NEWSPEC
  1.  D NEWTST S LRCOUNT=1
  1.  Q
  1. COND2 ;
  1.  D NEWPAT
  1.  D NEWSPEC
  1.  D NEWTST S LRCOUNT=1
  1.  Q
  1. COND3 ;
  1.  D NEWSPEC
  1.  D NEWTST S LRCOUNT=1
  1.  Q
  1. COND4 ;
  1.  D NEWTST S LRCOUNT=1
  1.  Q
  1. PAGE ;
  1.  W:$E(IOST,1,2)="C-" @IOF
  1.  D HDR1 S LRTOP=1
  1.  Q
  1. NEWPAT ;
  1.  ; D HDR2 S LRPATCK=SSN
  1.  D HDR2 S LRPATCK=HRCN
  1.  Q
  1. NEWSPEC ;
  1.  D PRSPEC S LRSPCK=LRSPEC
  1.  Q
  1. NEWTST ;
  1.  D PRTEST S LRTSTCK=LRTEST
  1.  Q
  1. SAMETST ;
  1.  D PRTEST
  1.  Q
  1. CHKPG ;
  1.  S:LRCNT<1 LRCNT=1
  1.  Q:$G(LREND)
  1.  I $Y>(IOSL-7-LRCNT) S NEWPG=1 D
  1.  .  D LEGEND W:$E(IOST,1,2)'="C-" @IOF
  1.  .  D:$E(IOST,1,2)="C-" WAIT Q:LREND  S LRTOP=1
  1.  Q
  1. PRSPEC ;
  1.  W ?2,$E(LRSPEC,1,10)
  1.  W ?14,$S(LRTHER:"Th. Range ",1:"Ref. Range:   "),LRLO
  1.  W "-",LRHI," ",LRUNITS,!
  1.  Q
  1. PRTEST ;
  1.  Q:$G(LRCOMX)
  1.  Q:$G(LREND)
  1.  S LRCOMX=0
  1.  W ?4,$E(LRTEST,1,12),?14,LRAN,?30,$J(LRVAL,4)
  1.  W ?33,LRMRK,?40,$E(LRCDT,1,6)_" "_$E($P(LRCDT,",",2),2,5)
  1.  W " at ",$P(LRCDT,"@",2)
  1.  W ?64,LRLOC,!
  1.  Q:$G(LREND)!(LRTOP)
  1.  Q
  1. COM ;Print comments on specimen
  1.  Q:$G(LREND)  W !," COMMENT(S): "
  1.  S C=""
  1.  F  S C=$O(^TMP("LR",$J,LRSUB1,LRSUB2,LRSUB3,LRAN,"COM",C)) Q:(C="")!(LREND)  D
  1.  .I $Y+7>IOSL D
  1.  ..D:$E(IOST,1,2)="C-" WAIT Q:LREND=1  D CHKPG
  1.  ..W !,"COMMENT(S): "
  1.  .Q:LREND
  1.  Q
  1. SUMMARY ;
  1.  I ($Y>(IOSL-7-LRCNT)) D:$E(IOST,1,2)="C-" WAIT Q:LREND=1  D CHKPG
  1.  D LEGEND
  1.  F I=$Y:1:(IOSL-6) W !
  1.  W !,?20,"END OF SPECIAL REPORT" QUIT
  1.  Q
  1. HDR1 ;
  1.  D LABHDR^BLRUTIL2           ; IHS/OIT/MKK -- LR*5.2*1030 -- Put Name/address in header
  1.  S LRTST(0)=$E(LRTST(0),1,30)
  1.  S %=32-$L(LRTST(0))\2+15
  1.  S LRPAG=LRPAG+1
  1.  W "SPECIAL REPORT",?31
  1.  W "Report Date:   "
  1.  W $$FMTE^XLFDT($$NOW^XLFDT,"")
  1.  W !,LRHDR2,?71,"Pg ",$J(LRPAG,3)
  1.  W ! D LRGLIN^LRX
  1.  S LRTOP=""
  1.  S LRCHKSP=0
  1.  Q
  1. HDR2 ;
  1.  ; W !,PNM,?28,SSN,?61,$E(LRWRD,1,16),!
  1.  W !,PNM,?28,HRCN,?61,$E(LRWRD,1,16),!      ; IHS/OIT/MKK -- LR*5.2*1030
  1.  Q
  1. WAIT W ! K DIR S DIR(0)="E" D ^DIR S:($D(DUOUT))!($D(DTOUT)) LREND=1
  1.  Q
  1. CHNCASE ;
  1.  S LRCHNG=$E(LRCHNG)_$$LOWCASE^LRAFUNC($E(LRCHNG,2,$L(LRCHNG)))
  1.  Q
  1. LEGEND ;
  1.  D LRGLIN^LRX
  1.  W !,"Search Criteria:"
  1.  F %=1:1:LRTST D
  1.  . W !,%,") " S LRCHNG=$E($P(LRTST(%,2),U,1),1,10) D CHNCASE
  1.  . W LRCHNG," "
  1.  . W $P(LRTST(%,2),U,3),"  Specimen: "
  1.  . W $S($P(LRTST(%,2),U,2)'="":$E($P(LRTST(%,2),U,2),1,79-$X),1:"Any")
  1.  Q