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

LRAPF.m

Go to the documentation of this file.
  1. LRAPF ;DALOI/STAFF - CY/EM/SP RPT ;11/14/11 13:04
  1. ;;5.2;LAB SERVICE;**173,201,248,259,350**;Sep 27, 1994;Build 230
  1. ;
  1. ; 23-MAR-01;WTY;Trimmed down DX in line tag F per SAM-0301-22193
  1. ;
  1. ; From LRSPRPT,LRSPRPT1, LRSPRPT2, LRSPRPTM
  1. I $D(LR("F")),IOST?1"C".E D Q:LR("Q")
  1. . K DIR S DIR(0)="E"
  1. . D ^DIR W !
  1. . S:$D(DTOUT)!(X[U) LR("Q")=1
  1. ;
  1. W:($D(LR("F"))) @IOF
  1. S LRQ=LRQ+1
  1. ;
  1. ; Print printing and reporting facility
  1. I LRQ=1,$$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1 D
  1. . N A
  1. . D PFAC^LRRP1(DUZ(2),0,1,.A)
  1. . S A=0
  1. . F S A=$O(A(A)) Q:'A W !,A(A)
  1. ;
  1. I LRQ=1,$$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2 D
  1. . N B,LRX
  1. . S LRX=+$G(^LR(LRDFN,LRSS,LRI,"RF"))
  1. . I LRX<1 Q
  1. . D RL^LRRP1(LRX,1,.B)
  1. . W ! S B=0
  1. . F S B=$O(B(B)) Q:'B W !,B(B)
  1. ;
  1. D W
  1. W !?5,"MEDICAL RECORD |",?40,LRAA(1),?73,"Pg ",LRQ
  1. D:LRQ>1 P
  1. D W
  1. Q
  1. ;
  1. ;
  1. F ; from LRSPRPT,LRSPRPT1, LRSPRPT2, LRSPRPTM
  1. Q:LR("Q")
  1. I IOSL'>66 F Q:$Y>(IOSL-11) W !
  1. D W W !,$S('$D(LR("W")):"",1:"See signed copy in chart")
  1. W ?57,"(",$S($D(LRO):"End of report",1:"See next page"),")"
  1. W !,$G(LRPMD),?52,LRW(9),?55,"| Date ",$G(LRRC)
  1. D W
  1. W !,LRP,?50,$S('$D(LR("W")):"STANDARD FORM 515",1:"WORK COPY ONLY !!")
  1. W !,"ID:",SSN,?16,"SEX:",SEX," DOB:",DOB
  1. I AGE W $S($G(VADM(6))'="":" AGE AT DEATH: ",1:" AGE: "),AGE
  1. W " LOC:",$E(LRLLOC,1,20)
  1. W ! W:LRADM'="" "ADM:",$P(LRADM,"@")
  1. W:LRADX'="" ?17,"DX:",$E(LRADX,1,26)
  1. W ?46,"PCP: "
  1. W:LRPRAC ?51,$E(LRPRAC(1),1,28)
  1. Q
  1. ;
  1. ;
  1. P ;
  1. ; Handle printing footer after printing prior cases on end of report and LRI now null.
  1. I $G(LRI)<1 N LRI S LRI=+$P($G(LRAP),"^",2)
  1. ;
  1. D:LRQ>1 W
  1. ;
  1. S ADESC="Accession No. "_$S(LRQ(8)]"":LRQ(8)_LRW(1)_" "_LRAC,1:LRAC)
  1. S LENG1=$L(LRQ(1)),LENG2=$L(ADESC),LNSPCE=IOM-LENG2-14
  1. S:LENG1>LNSPCE LRQ(1)=$E(LRQ(1),1,LNSPCE)
  1. ;
  1. W !?30,"PATHOLOGY REPORT",!
  1. ;
  1. I '$G(^LR(LRDFN,LRSS,+LRI,"RF")) W "Laboratory: ",LRQ(1)
  1. W ?(IOM-LENG2-1),ADESC
  1. ;
  1. K ADESC,LENG1,LENG2,LNSPCE
  1. Q
  1. ;
  1. ;
  1. W ;
  1. W !,LR("%")
  1. Q