- 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
