- LRAPF ;DALOI/STAFF - CY/EM/SP RPT ;11/14/11 13:04
- ;;5.2;LAB SERVICE;**173,201,248,259,350**;Sep 27, 1994;Build 230
- ;
- ; 23-MAR-01;WTY;Trimmed down DX in line tag F per SAM-0301-22193
- ;
- ; From LRSPRPT,LRSPRPT1, LRSPRPT2, LRSPRPTM
- I $D(LR("F")),IOST?1"C".E D Q:LR("Q")
- . K DIR S DIR(0)="E"
- . D ^DIR W !
- . S:$D(DTOUT)!(X[U) LR("Q")=1
- ;
- W:($D(LR("F"))) @IOF
- S LRQ=LRQ+1
- ;
- ; Print printing and reporting facility
- I LRQ=1,$$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1 D
- . N A
- . D PFAC^LRRP1(DUZ(2),0,1,.A)
- . S A=0
- . F S A=$O(A(A)) Q:'A W !,A(A)
- ;
- I LRQ=1,$$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2 D
- . N B,LRX
- . S LRX=+$G(^LR(LRDFN,LRSS,LRI,"RF"))
- . I LRX<1 Q
- . D RL^LRRP1(LRX,1,.B)
- . W ! S B=0
- . F S B=$O(B(B)) Q:'B W !,B(B)
- ;
- D W
- W !?5,"MEDICAL RECORD |",?40,LRAA(1),?73,"Pg ",LRQ
- D:LRQ>1 P
- D W
- Q
- ;
- ;
- F ; from LRSPRPT,LRSPRPT1, LRSPRPT2, LRSPRPTM
- Q:LR("Q")
- I IOSL'>66 F Q:$Y>(IOSL-11) W !
- D W W !,$S('$D(LR("W")):"",1:"See signed copy in chart")
- W ?57,"(",$S($D(LRO):"End of report",1:"See next page"),")"
- W !,$G(LRPMD),?52,LRW(9),?55,"| Date ",$G(LRRC)
- D W
- W !,LRP,?50,$S('$D(LR("W")):"STANDARD FORM 515",1:"WORK COPY ONLY !!")
- W !,"ID:",SSN,?16,"SEX:",SEX," DOB:",DOB
- I AGE W $S($G(VADM(6))'="":" AGE AT DEATH: ",1:" AGE: "),AGE
- W " LOC:",$E(LRLLOC,1,20)
- W ! W:LRADM'="" "ADM:",$P(LRADM,"@")
- W:LRADX'="" ?17,"DX:",$E(LRADX,1,26)
- W ?46,"PCP: "
- W:LRPRAC ?51,$E(LRPRAC(1),1,28)
- Q
- ;
- ;
- P ;
- ; Handle printing footer after printing prior cases on end of report and LRI now null.
- I $G(LRI)<1 N LRI S LRI=+$P($G(LRAP),"^",2)
- ;
- D:LRQ>1 W
- ;
- S ADESC="Accession No. "_$S(LRQ(8)]"":LRQ(8)_LRW(1)_" "_LRAC,1:LRAC)
- S LENG1=$L(LRQ(1)),LENG2=$L(ADESC),LNSPCE=IOM-LENG2-14
- S:LENG1>LNSPCE LRQ(1)=$E(LRQ(1),1,LNSPCE)
- ;
- W !?30,"PATHOLOGY REPORT",!
- ;
- I '$G(^LR(LRDFN,LRSS,+LRI,"RF")) W "Laboratory: ",LRQ(1)
- W ?(IOM-LENG2-1),ADESC
- ;
- K ADESC,LENG1,LENG2,LNSPCE
- Q
- ;
- ;
- W ;
- W !,LR("%")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPF 2041 printed Jan 18, 2025@03:08:06 Page 2
- 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
- +2 ;
- +3 ; 23-MAR-01;WTY;Trimmed down DX in line tag F per SAM-0301-22193
- +4 ;
- +5 ; From LRSPRPT,LRSPRPT1, LRSPRPT2, LRSPRPTM
- +6 IF $DATA(LR("F"))
- IF IOST?1"C".E
- Begin DoDot:1
- +7 KILL DIR
- SET DIR(0)="E"
- +8 DO ^DIR
- WRITE !
- +9 if $DATA(DTOUT)!(X[U)
- SET LR("Q")=1
- End DoDot:1
- if LR("Q")
- QUIT
- +10 ;
- +11 if ($DATA(LR("F")))
- WRITE @IOF
- +12 SET LRQ=LRQ+1
- +13 ;
- +14 ; Print printing and reporting facility
- +15 IF LRQ=1
- IF $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1
- Begin DoDot:1
- +16 NEW A
- +17 DO PFAC^LRRP1(DUZ(2),0,1,.A)
- +18 SET A=0
- +19 FOR
- SET A=$ORDER(A(A))
- if 'A
- QUIT
- WRITE !,A(A)
- End DoDot:1
- +20 ;
- +21 IF LRQ=1
- IF $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2
- Begin DoDot:1
- +22 NEW B,LRX
- +23 SET LRX=+$GET(^LR(LRDFN,LRSS,LRI,"RF"))
- +24 IF LRX<1
- QUIT
- +25 DO RL^LRRP1(LRX,1,.B)
- +26 WRITE !
- SET B=0
- +27 FOR
- SET B=$ORDER(B(B))
- if 'B
- QUIT
- WRITE !,B(B)
- End DoDot:1
- +28 ;
- +29 DO W
- +30 WRITE !?5,"MEDICAL RECORD |",?40,LRAA(1),?73,"Pg ",LRQ
- +31 if LRQ>1
- DO P
- +32 DO W
- +33 QUIT
- +34 ;
- +35 ;
- F ; from LRSPRPT,LRSPRPT1, LRSPRPT2, LRSPRPTM
- +1 if LR("Q")
- QUIT
- +2 IF IOSL'>66
- FOR
- if $Y>(IOSL-11)
- QUIT
- WRITE !
- +3 DO W
- WRITE !,$SELECT('$DATA(LR("W")):"",1:"See signed copy in chart")
- +4 WRITE ?57,"(",$SELECT($DATA(LRO):"End of report",1:"See next page"),")"
- +5 WRITE !,$GET(LRPMD),?52,LRW(9),?55,"| Date ",$GET(LRRC)
- +6 DO W
- +7 WRITE !,LRP,?50,$SELECT('$DATA(LR("W")):"STANDARD FORM 515",1:"WORK COPY ONLY !!")
- +8 WRITE !,"ID:",SSN,?16,"SEX:",SEX," DOB:",DOB
- +9 IF AGE
- WRITE $SELECT($GET(VADM(6))'="":" AGE AT DEATH: ",1:" AGE: "),AGE
- +10 WRITE " LOC:",$EXTRACT(LRLLOC,1,20)
- +11 WRITE !
- if LRADM'=""
- WRITE "ADM:",$PIECE(LRADM,"@")
- +12 if LRADX'=""
- WRITE ?17,"DX:",$EXTRACT(LRADX,1,26)
- +13 WRITE ?46,"PCP: "
- +14 if LRPRAC
- WRITE ?51,$EXTRACT(LRPRAC(1),1,28)
- +15 QUIT
- +16 ;
- +17 ;
- P ;
- +1 ; Handle printing footer after printing prior cases on end of report and LRI now null.
- +2 IF $GET(LRI)<1
- NEW LRI
- SET LRI=+$PIECE($GET(LRAP),"^",2)
- +3 ;
- +4 if LRQ>1
- DO W
- +5 ;
- +6 SET ADESC="Accession No. "_$SELECT(LRQ(8)]"":LRQ(8)_LRW(1)_" "_LRAC,1:LRAC)
- +7 SET LENG1=$LENGTH(LRQ(1))
- SET LENG2=$LENGTH(ADESC)
- SET LNSPCE=IOM-LENG2-14
- +8 if LENG1>LNSPCE
- SET LRQ(1)=$EXTRACT(LRQ(1),1,LNSPCE)
- +9 ;
- +10 WRITE !?30,"PATHOLOGY REPORT",!
- +11 ;
- +12 IF '$GET(^LR(LRDFN,LRSS,+LRI,"RF"))
- WRITE "Laboratory: ",LRQ(1)
- +13 WRITE ?(IOM-LENG2-1),ADESC
- +14 ;
- +15 KILL ADESC,LENG1,LENG2,LNSPCE
- +16 QUIT
- +17 ;
- +18 ;
- W ;
- +1 WRITE !,LR("%")
- +2 QUIT