- LRAPBR ;VA/DALOI/WTY - AP Browser Print/TIU TMP Global;04/03/01
- ;;5.2;LAB SERVICE;**1030**;NOV 01, 1997
- ;;5.2;LAB SERVICE;**259**;Sep 27, 1994
- ;
- ;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 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
- LRAPBR ;VA/DALOI/WTY - AP Browser Print/TIU TMP Global;04/03/01
- +1 ;;5.2;LAB SERVICE;**1030**;NOV 01, 1997
- +2 ;;5.2;LAB SERVICE;**259**;Sep 27, 1994
- +3 ;
- +4 ;Reference to ^DPT supported by IA #918
- +5 ;
- 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 FOOTER^LRAPBR1
- +9 IF 'LRTIU
- DO BROWSER
- +10 DO END
- +11 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
