LRAPBR ;DALOI/WTY - AP Browser Print/TIU TMP Global;11/21/12 15:12
;;5.2;LAB SERVICE;**259,427**;Sep 27, 1994;Build 33
;
;Reference to ^DPT supported by IA #918
;
INIT(LRAA,LRSS,LRI,LRDFN,LRAA1,LRAU,LRTIU,LRNTIME) ;
;Define variables and arrays used for report display
N LRIENS,LCT,LREFLG,LRPRAC
S:'$D(LRTIU) LRTIU=0
;KLL-Change all "-" and "=" to "- " and "=-"
S $P(LR("%"),"- ",IOM/2)="- "
I $L(LR("%"))>(IOM-1) S LR("%")=$E(LR("%"),1,(IOM-1))
S $P(LR("%1"),"=-",IOM/2)="=-"
I $L(LR("%1"))>(IOM-1) S LR("%1")=$E(LR("%1"),1,(IOM-1))
S LRQ(8)=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),"^",8),1:"")
S LRQ=0,LRQ(1)=$$INS^LRU
I LRAU D
.S LRS="W",LRAP=LRDFN,LRXR="A"_LRSS,LRXREF=LRXR_"A"
.S LR(.21)=+$G(^LRO(69.2,LRAA,.2)),LRS(5)=1
.D EN^LRUA
.D ^LRUP
I 'LRAU D
.D SET^LRUA
.S LRA=1
.S LRS(5)=1,LRQ(2)=1
.S LR("DIWF")=$S($P(^LRO(69.2,LRAA,0),"^",6)="D":"D",1:"")_"W"
MAIN ;Main Subroutine
K ^UTILITY($J)
D:'LRAU ENTER^LRAPBR1
D:LRAU ENTER^LRAPBR4
I 'LRAU,'LRTIU D
.D POW,^LRAPBR2
.I $D(^LR(LRDFN,"AU")),$P(^LR(LRDFN,"AU"),"^") D ^LRAPBR5
I LRTIU,'LRAU D ESIGLN^LRAPBR1
D:'LRAU PPL^LRAPBR1
D:'LRAU FOOTER^LRAPBR1
D:'LRTIU BROWSER
D END
Q
POW ;Determine POW or Persian Gulf status
I $P($G(^LR(LRDFN,0)),"^",2)=2 D
.S LRPOW=0
.I $D(^DPT(DFN,.52)) S:$P(^(.52),U,5)="Y" LRPOW=1
.I $D(^DPT(DFN,.322)) S:$P($G(^(.322)),"^",10)="Y" LRPOW=1
.D ^LRAPBRPW
.K LRPOW
Q
FINAL ;Final Section
;Print text in field SNOMED & TC CODING (#10) of the LAB SECTION
;PRINT FILE (#69.2)
Q:'$P($G(^LRO(69.2,LRAA,10,0)),"^",4)
K LRTMP,^UTILITY($J,"W")
S LRFILE=69.2,LRFLD=10,LRIENS=LRAA_","
N X,DIWR,DIWL
S X=$$GET1^DIQ(LRFILE,LRIENS,LRFLD,"","LRTMP")
S DIWR=IOM-5,DIWL=5,DIWF=""
S X=+$$GET1^DID(LRFILE,LRFLD,"","SPECIFIER")
I $$GET1^DID(X,.01,"","SPECIFIER")["L" S DIWF="N"
S A=0 F S A=$O(LRTMP(A)) Q:'A S X=LRTMP(A) D ^DIWP
S A=0 F S A=$O(^UTILITY($J,"W",DIWL,A)) Q:'A D
.D GLENTRY^LRAPBR1(^UTILITY($J,"W",DIWL,A,0),DIWL,1)
K ^UTILITY($J,"W")
Q
BROWSER ;
;SET LRW(1)=2-DIGIT YEAR OF AUTOPSY DATE
I LRAU,LRQ(8)'="" S LRW(1)=$E(+$$GET1^DIQ(63,LRDFN,11,"I"),2,3)
S LRTITLE=$S(LRQ(8)'="":LRQ(8)_LRW(1)_" "_LRAC,1:LRAC)_" - "_LRP
S LRROOT="^TMP(""LRAPBR"",$J)"
D BROWSE^DDBR(LRROOT,"",LRTITLE)
Q
END ;
K LRSR1,LRSR2,LRTEXT,LRTIU,LRTITLE,LRROOT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPBR 2347 printed Oct 16, 2024@18:07:44 Page 2
LRAPBR ;DALOI/WTY - AP Browser Print/TIU TMP Global;11/21/12 15:12
+1 ;;5.2;LAB SERVICE;**259,427**;Sep 27, 1994;Build 33
+2 ;
+3 ;Reference to ^DPT supported by IA #918
+4 ;
INIT(LRAA,LRSS,LRI,LRDFN,LRAA1,LRAU,LRTIU,LRNTIME) ;
+1 ;Define variables and arrays used for report display
+2 NEW LRIENS,LCT,LREFLG,LRPRAC
+3 if '$DATA(LRTIU)
SET LRTIU=0
+4 ;KLL-Change all "-" and "=" to "- " and "=-"
+5 SET $PIECE(LR("%"),"- ",IOM/2)="- "
+6 IF $LENGTH(LR("%"))>(IOM-1)
SET LR("%")=$EXTRACT(LR("%"),1,(IOM-1))
+7 SET $PIECE(LR("%1"),"=-",IOM/2)="=-"
+8 IF $LENGTH(LR("%1"))>(IOM-1)
SET LR("%1")=$EXTRACT(LR("%1"),1,(IOM-1))
+9 SET LRQ(8)=$SELECT($DATA(^LRO(69.2,LRAA,0)):$PIECE(^(0),"^",8),1:"")
+10 SET LRQ=0
SET LRQ(1)=$$INS^LRU
+11 IF LRAU
Begin DoDot:1
+12 SET LRS="W"
SET LRAP=LRDFN
SET LRXR="A"_LRSS
SET LRXREF=LRXR_"A"
+13 SET LR(.21)=+$GET(^LRO(69.2,LRAA,.2))
SET LRS(5)=1
+14 DO EN^LRUA
+15 DO ^LRUP
End DoDot:1
+16 IF 'LRAU
Begin DoDot:1
+17 DO SET^LRUA
+18 SET LRA=1
+19 SET LRS(5)=1
SET LRQ(2)=1
+20 SET LR("DIWF")=$SELECT($PIECE(^LRO(69.2,LRAA,0),"^",6)="D":"D",1:"")_"W"
End DoDot:1
MAIN ;Main Subroutine
+1 KILL ^UTILITY($JOB)
+2 if 'LRAU
DO ENTER^LRAPBR1
+3 if LRAU
DO ENTER^LRAPBR4
+4 IF 'LRAU
IF 'LRTIU
Begin DoDot:1
+5 DO POW
DO ^LRAPBR2
+6 IF $DATA(^LR(LRDFN,"AU"))
IF $PIECE(^LR(LRDFN,"AU"),"^")
DO ^LRAPBR5
End DoDot:1
+7 IF LRTIU
IF 'LRAU
DO ESIGLN^LRAPBR1
+8 if 'LRAU
DO PPL^LRAPBR1
+9 if 'LRAU
DO FOOTER^LRAPBR1
+10 if 'LRTIU
DO BROWSER
+11 DO END
+12 QUIT
POW ;Determine POW or Persian Gulf status
+1 IF $PIECE($GET(^LR(LRDFN,0)),"^",2)=2
Begin DoDot:1
+2 SET LRPOW=0
+3 IF $DATA(^DPT(DFN,.52))
if $PIECE(^(.52),U,5)="Y"
SET LRPOW=1
+4 IF $DATA(^DPT(DFN,.322))
if $PIECE($GET(^(.322)),"^",10)="Y"
SET LRPOW=1
+5 DO ^LRAPBRPW
+6 KILL LRPOW
End DoDot:1
+7 QUIT
FINAL ;Final Section
+1 ;Print text in field SNOMED & TC CODING (#10) of the LAB SECTION
+2 ;PRINT FILE (#69.2)
+3 if '$PIECE($GET(^LRO(69.2,LRAA,10,0)),"^",4)
QUIT
+4 KILL LRTMP,^UTILITY($JOB,"W")
+5 SET LRFILE=69.2
SET LRFLD=10
SET LRIENS=LRAA_","
+6 NEW X,DIWR,DIWL
+7 SET X=$$GET1^DIQ(LRFILE,LRIENS,LRFLD,"","LRTMP")
+8 SET DIWR=IOM-5
SET DIWL=5
SET DIWF=""
+9 SET X=+$$GET1^DID(LRFILE,LRFLD,"","SPECIFIER")
+10 IF $$GET1^DID(X,.01,"","SPECIFIER")["L"
SET DIWF="N"
+11 SET A=0
FOR
SET A=$ORDER(LRTMP(A))
if 'A
QUIT
SET X=LRTMP(A)
DO ^DIWP
+12 SET A=0
FOR
SET A=$ORDER(^UTILITY($JOB,"W",DIWL,A))
if 'A
QUIT
Begin DoDot:1
+13 DO GLENTRY^LRAPBR1(^UTILITY($JOB,"W",DIWL,A,0),DIWL,1)
End DoDot:1
+14 KILL ^UTILITY($JOB,"W")
+15 QUIT
BROWSER ;
+1 ;SET LRW(1)=2-DIGIT YEAR OF AUTOPSY DATE
+2 IF LRAU
IF LRQ(8)'=""
SET LRW(1)=$EXTRACT(+$$GET1^DIQ(63,LRDFN,11,"I"),2,3)
+3 SET LRTITLE=$SELECT(LRQ(8)'="":LRQ(8)_LRW(1)_" "_LRAC,1:LRAC)_" - "_LRP
+4 SET LRROOT="^TMP(""LRAPBR"",$J)"
+5 DO BROWSE^DDBR(LRROOT,"",LRTITLE)
+6 QUIT
END ;
+1 KILL LRSR1,LRSR2,LRTEXT,LRTIU,LRTITLE,LRROOT
+2 QUIT
