LRAPF ;AVAMC/REG/WTY - CY/EM/SP RPT ;9/25/00
;;5.2;LAB SERVICE;**1003,1006,1018,1020,1030,1031**;NOV 01, 1997
;
; VA LR Patch(s): 173,201,248,259
;
;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
W !
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-14) 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
W !,"ID:",HRCN,?16,"SEX:",SEX," DOB:",DOB ; IHS/MSC/MKK 1031: restoring LR*5.2*1018 mod
W:AGE $S($G(VADM(6))]"":" AGE AT DEATH: ",1:" AGE: "),AGE
W " LOC:",$E(LRLLOC,1,20)
W ! W:$L(LRADM) "ADM:",$P(LRADM,"@")
W:$L(LRADX) ?17,"DX:",$E(LRADX,1,26)
W ?46,"PCP: "
W:LRPRAC ?51,$E(LRPRAC(1),1,28)
D NAMER ; IHS/MSC/MKK - LR*5.2*1031
Q
;
P 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"
W !,"Laboratory: ",LRQ(1)
W ?(IOM-LENG2-1),ADESC
K ADESC,LENG1,LENG2,LNSPCE
Q
W W !,LR("%")
Q
;
; IHS/MSC/MKK - LR*5.2*1031 -- Put back in LR*5.2*1020 Changes
;
;----- BEGIN IHS MODIFICATIONS LR*5.2*1020 -- Name, Address & Phone # on Report
NAMER ;
NEW STR,STRA,STRN,STRO,STRT
;
; Get ADDRESS from the BLR MASTER CONTROL file
S STRA=$$GET1^DIQ(9009029,$G(DUZ(2)),"PATH ADDR1")
S STR=$$GET1^DIQ(9009029,$G(DUZ(2)),"PATH ADDR2")
I $G(STR)'="" S STRA=STRA_" "_STR
S STRA=STRA_" "_$$GET1^DIQ(9009029,$G(DUZ(2)),"PATH CITY")
S STRA=STRA_", "_$$GET1^DIQ(9009029,$G(DUZ(2)),"PATH STATE:ABBREVIATION")
S STRA=STRA_" "_$$GET1^DIQ(9009029,$G(DUZ(2)),"PATH ZIP")
;
; If ADDRESS is not in BLR MASTER CONTROL, try the INSTITUTION file
I $TR($TR(STRA,",")," ")="" D
. S STRA=$$GET1^DIQ(4,$G(DUZ(2)),"STREET ADDR. 1")
. S STR=$$GET1^DIQ(4,$G(DUZ(2)),"STREET ADDR. 2")
. I $G(STR)'="" S STRA=STRA_" "_STR
. S STRA=STRA_" "_$$GET1^DIQ(4,$G(DUZ(2)),"CITY")
. S STRA=STRA_", "_$$GET1^DIQ(4,$G(DUZ(2)),"STATE:ABBREVIATION")
. S STRA=STRA_" "_$$GET1^DIQ(4,$G(DUZ(2)),"ZIP")
;
I $TR($TR(STRA,",")," ")="" Q ; If there is no address, skip
;
; Pathology "Institution" Name
S STRN=$$GET1^DIQ(9009029,$G(DUZ(2)),"PATH INST")
I $G(STRN)="" S STRN=$$NAME^XUAF4($G(DUZ(2))) ; If no data, get Institution Name
;
I $TR(STRN," ")="" Q ; If there is no site name, skip
;
I ($L(STRA)+$L(STRN)+8)>IOM D ; May need to use 2 lines
. W !!,$$CJ^XLFSTR(STRN,IOM)
. W !,$$CJ^XLFSTR(STRA,IOM),!
I ($L(STRA)+$L(STRN)+8)<IOM D ; Just use 1 line
. W !!,$$CJ^XLFSTR(STRN_" "_STRA,IOM),!
I ($L(STRA)+$L(STRN)+8)=IOM D
. W !!,$$CJ^XLFSTR(STRN_" "_STRA,IOM),!
;
S STRO=" " ; Name & Phone Number & Title, if they exist
S STRN=$$GET1^DIQ(9009029,$G(DUZ(2)),"PATH NAME:SIGNATURE BLOCK PRINTED NAME")
I $G(STRN)'="" D
. S STRT=$$GET1^DIQ(9009029,$G(DUZ(2)),"PATH TITLE")
. I $G(STRT)="" S STRO="Pathology:"_STRN
. I $G(STRT)'="" S STRO=STRT_":"_STRN
S STRA=$$GET1^DIQ(9009029,$G(DUZ(2)),"PATH PHONE")
I $G(STRA)'="" S STRO=STRO_" Phone:"_STRA
I $TR(STRO," ")="" Q
;
S STRO=$$TRIM^XLFSTR(STRO,"L"," ")
W $$CJ^XLFSTR(STRO,IOM),!
Q
;----- END IHS MODIFICATIONS LR*5.2*1020 -- Name, Address & Phone # on Report
LRAPF ;AVAMC/REG/WTY - CY/EM/SP RPT ;9/25/00
+1 ;;5.2;LAB SERVICE;**1003,1006,1018,1020,1030,1031**;NOV 01, 1997
+2 ;
+3 ; VA LR Patch(s): 173,201,248,259
+4 ;
+5 ;23-MAR-01;WTY;Trimmed down DX in line tag F per SAM-0301-22193
+6 ;
+7 ;from LRSPRPT,LRSPRPT1, LRSPRPT2, LRSPRPTM
+8 IF $DATA(LR("F"))
IF IOST?1"C".E
Begin DoDot:1
+9 KILL DIR
SET DIR(0)="E"
+10 DO ^DIR
WRITE !
+11 IF $DATA(DTOUT)!(X[U)
SET LR("Q")=1
End DoDot:1
IF LR("Q")
QUIT
+12 IF ($DATA(LR("F")))
WRITE @IOF
+13 SET LRQ=LRQ+1
+14 WRITE !
+15 DO W
+16 WRITE !?5,"MEDICAL RECORD |",?40,LRAA(1),?73,"Pg ",LRQ
+17 IF LRQ>1
DO P
+18 DO W
+19 QUIT
F ;from LRSPRPT,LRSPRPT1, LRSPRPT2, LRSPRPTM
+1 IF LR("Q")
QUIT
+2 IF IOSL'>66
FOR
IF $Y>(IOSL-14)
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 ; W !,"ID:",SSN,?16,"SEX:",SEX," DOB:",DOB
+9 ; IHS/MSC/MKK 1031: restoring LR*5.2*1018 mod
WRITE !,"ID:",HRCN,?16,"SEX:",SEX," DOB:",DOB
+10 IF AGE
WRITE $SELECT($GET(VADM(6))]"":" AGE AT DEATH: ",1:" AGE: "),AGE
+11 WRITE " LOC:",$EXTRACT(LRLLOC,1,20)
+12 WRITE !
IF $LENGTH(LRADM)
WRITE "ADM:",$PIECE(LRADM,"@")
+13 IF $LENGTH(LRADX)
WRITE ?17,"DX:",$EXTRACT(LRADX,1,26)
+14 WRITE ?46,"PCP: "
+15 IF LRPRAC
WRITE ?51,$EXTRACT(LRPRAC(1),1,28)
+16 ; IHS/MSC/MKK - LR*5.2*1031
DO NAMER
+17 QUIT
+18 ;
P IF LRQ>1
DO W
+1 SET ADESC="Accession No. "_$SELECT(LRQ(8)]"":LRQ(8)_LRW(1)_" "_LRAC,1:LRAC)
+2 SET LENG1=$LENGTH(LRQ(1))
SET LENG2=$LENGTH(ADESC)
SET LNSPCE=IOM-LENG2-14
+3 IF LENG1>LNSPCE
SET LRQ(1)=$EXTRACT(LRQ(1),1,LNSPCE)
+4 WRITE !?30,"PATHOLOGY REPORT"
+5 WRITE !,"Laboratory: ",LRQ(1)
+6 WRITE ?(IOM-LENG2-1),ADESC
+7 KILL ADESC,LENG1,LENG2,LNSPCE
+8 QUIT
W WRITE !,LR("%")
+1 QUIT
+2 ;
+3 ; IHS/MSC/MKK - LR*5.2*1031 -- Put back in LR*5.2*1020 Changes
+4 ;
+5 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1020 -- Name, Address & Phone # on Report
NAMER ;
+1 NEW STR,STRA,STRN,STRO,STRT
+2 ;
+3 ; Get ADDRESS from the BLR MASTER CONTROL file
+4 SET STRA=$$GET1^DIQ(9009029,$GET(DUZ(2)),"PATH ADDR1")
+5 SET STR=$$GET1^DIQ(9009029,$GET(DUZ(2)),"PATH ADDR2")
+6 IF $GET(STR)'=""
SET STRA=STRA_" "_STR
+7 SET STRA=STRA_" "_$$GET1^DIQ(9009029,$GET(DUZ(2)),"PATH CITY")
+8 SET STRA=STRA_", "_$$GET1^DIQ(9009029,$GET(DUZ(2)),"PATH STATE:ABBREVIATION")
+9 SET STRA=STRA_" "_$$GET1^DIQ(9009029,$GET(DUZ(2)),"PATH ZIP")
+10 ;
+11 ; If ADDRESS is not in BLR MASTER CONTROL, try the INSTITUTION file
+12 IF $TRANSLATE($TRANSLATE(STRA,",")," ")=""
Begin DoDot:1
+13 SET STRA=$$GET1^DIQ(4,$GET(DUZ(2)),"STREET ADDR. 1")
+14 SET STR=$$GET1^DIQ(4,$GET(DUZ(2)),"STREET ADDR. 2")
+15 IF $GET(STR)'=""
SET STRA=STRA_" "_STR
+16 SET STRA=STRA_" "_$$GET1^DIQ(4,$GET(DUZ(2)),"CITY")
+17 SET STRA=STRA_", "_$$GET1^DIQ(4,$GET(DUZ(2)),"STATE:ABBREVIATION")
+18 SET STRA=STRA_" "_$$GET1^DIQ(4,$GET(DUZ(2)),"ZIP")
End DoDot:1
+19 ;
+20 ; If there is no address, skip
IF $TRANSLATE($TRANSLATE(STRA,",")," ")=""
QUIT
+21 ;
+22 ; Pathology "Institution" Name
+23 SET STRN=$$GET1^DIQ(9009029,$GET(DUZ(2)),"PATH INST")
+24 ; If no data, get Institution Name
IF $GET(STRN)=""
SET STRN=$$NAME^XUAF4($GET(DUZ(2)))
+25 ;
+26 ; If there is no site name, skip
IF $TRANSLATE(STRN," ")=""
QUIT
+27 ;
+28 ; May need to use 2 lines
IF ($LENGTH(STRA)+$LENGTH(STRN)+8)>IOM
Begin DoDot:1
+29 WRITE !!,$$CJ^XLFSTR(STRN,IOM)
+30 WRITE !,$$CJ^XLFSTR(STRA,IOM),!
End DoDot:1
+31 ; Just use 1 line
IF ($LENGTH(STRA)+$LENGTH(STRN)+8)<IOM
Begin DoDot:1
+32 WRITE !!,$$CJ^XLFSTR(STRN_" "_STRA,IOM),!
End DoDot:1
+33 IF ($LENGTH(STRA)+$LENGTH(STRN)+8)=IOM
Begin DoDot:1
+34 WRITE !!,$$CJ^XLFSTR(STRN_" "_STRA,IOM),!
End DoDot:1
+35 ;
+36 ; Name & Phone Number & Title, if they exist
SET STRO=" "
+37 SET STRN=$$GET1^DIQ(9009029,$GET(DUZ(2)),"PATH NAME:SIGNATURE BLOCK PRINTED NAME")
+38 IF $GET(STRN)'=""
Begin DoDot:1
+39 SET STRT=$$GET1^DIQ(9009029,$GET(DUZ(2)),"PATH TITLE")
+40 IF $GET(STRT)=""
SET STRO="Pathology:"_STRN
+41 IF $GET(STRT)'=""
SET STRO=STRT_":"_STRN
End DoDot:1
+42 SET STRA=$$GET1^DIQ(9009029,$GET(DUZ(2)),"PATH PHONE")
+43 IF $GET(STRA)'=""
SET STRO=STRO_" Phone:"_STRA
+44 IF $TRANSLATE(STRO," ")=""
QUIT
+45 ;
+46 SET STRO=$$TRIM^XLFSTR(STRO,"L"," ")
+47 WRITE $$CJ^XLFSTR(STRO,IOM),!
+48 QUIT
+49 ;----- END IHS MODIFICATIONS LR*5.2*1020 -- Name, Address & Phone # on Report
