LRAPBR1 ;DALOI/STAFF - AP Browser Print Cont. ; 26 Jul 2016 5:01 PM
;;5.2;LAB SERVICE;**259,317,363,350,427,464**;Sep 27, 1994;Build 12
;
;
ENTER ; from LRAPBR
N LRCNT,LRTMP,LRA1,LRADESC,LRLENG1,LRLENG2,LRFILE,LRAPMD
N LRFLD,LRV,LRV1,LRV2,LRX,LRB1,LRTEXT,LRSPCE,LRIENS,LRAPMR
Q:'$D(^LR(LRDFN,LRSS,LRI,0))
S:'LRTIU GROOT="^TMP(""LRAPBR"",$J,"
S:LRTIU GROOT="^TMP(""TIUP"",$J,"
;
D GETPCP^LRAPUTL(.LRPRAC,LRDFN,LRSS,LRI)
;
; If reporting lab available then use instead of VistA site name.
S LRX=+$G(^LR(LRDFN,LRSS,LRI,"RF"))
I LRX S LRQ(1)=$$NAME^XUAF4(LRX)
;
S LRQ=0 D ^LRUA,HEADER
S LR("F")=1
D DASH
D:LRTIU GLENTRY("$TEXT",,1)
D GLENTRY("Submitted by: "_LRW(5),"",1)
D GLENTRY("Date obtained: "_LRTK,44)
D:LRA DASH
;
S LRIENS=LRI_","_LRDFN_","
;
;
MAIN ;
D SPEC
D MODCHK
D SUPBNNR
; DALOI/LMT - LR,427 - Removed comments from report to restore pre-LR,350 behavior
;D COMMENT
D DIAG
D DOC
D WPFLD
D SUPRPT
D SSJR
Q
;
;
SPEC ; List specimens
;
;ZEXCEPT: LRDFN,LRI,LRIENS,LRSF,LRSS
;
N LRB,LRFILE,LRX
;
D GLENTRY("Specimen (Received "_LRTK(1)_"):","",1)
;
S LRFILE=+$$GET1^DID(LRSF,.012,"","SPECIFIER")
S LRB=0
F S LRB=$O(^LR(LRDFN,LRSS,LRI,.1,LRB)) Q:LRB<1 D
. S LRX=$$GET1^DIQ(LRFILE,LRB_","_LRIENS,.01)
. D GLENTRY(LRX,"",1)
;
Q
;
;
MODCHK ; Display modified banner if required
S LRAPMR=$$GET1^DIQ(LRSF,LRIENS,.17,"I")
Q:'LRAPMR
S LRAPMD=$$GET1^DIQ(LRSF,LRIENS,.172,"I")
D GLENTRY("","",1)
S LRTEXT=""
F LRCNT=1:1:$S(LRAPMD:14,1:15) D
. S LRTEXT=LRTEXT_"*+"
S LRTEXT=LRTEXT_" MODIFIED "
S LRTEXT=LRTEXT_$S(LRAPMD:"DIAGNOSIS ",1:"REPORT ")
F LRCNT=1:1:$S(LRAPMD:14,1:15) D
. S LRTEXT=LRTEXT_"*+"
D GLENTRY(LRTEXT,"",1)
D GLENTRY("","",1)
Q
;
;
SUPBNNR ; Display supplementary report header if one or more has been added
I $P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4) D
. S LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED *+*"
. D GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1)
. S LRTEXT="*+* REFER TO BOTTOM OF REPORT *+*"
. D GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1)
. D GLENTRY("","",1)
Q
;
;
DIAG ; Display the Brief Clinical History, Preoperative Diagnosis, Operative Findings, and Postoperative Diagnosis
S LRFILE=LRSF,LRCNT=0,LRIENS=LRI_","_LRDFN_","
F LRFLD=.013:.001:.016 D
. D:LRA DASH
. S LRCNT=LRCNT+1
. D GLENTRY($P($T(TEXT1+LRCNT),";",3),"",1)
. D WP
Q
;
;
DOC ; Pathologist information
;
N LRIENS,LRX
D GLENTRY("","",1)
;
; Retrieve surgeon/attending
D ATTEND(.LRMD)
D GLENTRY("Surgeon/physician: "_LRMD,27,1)
I LRMD("SR-SURGEON")'="" D GLENTRY(LRMD("SR-SURGEON"),28,1)
I LRMD("SR-ATTEND")'="" D GLENTRY(LRMD("SR-ATTEND"),26,1)
;I +$G(LRMD("ERR"))=601 D GLENTRY($P(LRMD("ERR"),"^",2),26,1)
;
D:LRA GLENTRY(LR("%1"),"",1)
D DASH
D HEADER2
D:LRA DASH
I LRRC="" D
. D GLENTRY("+*+* REPORT INCOMPLETE *+*+",20,1)
. D GLENTRY("","",1)
D GLENTRY("","",1)
I LRRMD'="" D
. S LRCNT=0 F LRA1="SP","CY","EM" D
. . S LRCNT=LRCNT+1
. . S LRTMP(LRA1)=$P($T(TEXT2+LRCNT),";",4)
. S LRTMP=LRTMP(LRSS)
. D GLENTRY(LRTMP_" "_LRRMD,31)
Q
;
;
WPFLD ; Display Frozen Section, Gross Description, Microscopic Description and Surgical Path Diagnosis
F LRCNT=1:1:4 D
. S X=$T(FIELDS+LRCNT)
. S LRV=$P(X,";",3),LRV1=$P(X,";",4),LRV2=$P(X,";",5)
. D TEXTCHK
. I $P($G(^LR(LRDFN,LRSS,LRI,LRV,0)),U,4) D
. . D GLENTRY("","",1),GLENTRY(LR(69.2,LRV1),"",1)
. . S LRFILE=LRSF,LRIENS=LRI_","_LRDFN_",",LRFLD=LRV
. . I $P($G(^LR(LRDFN,LRSS,LRI,LRV2,0)),U,4) D
. . . S LRFILE1=+$$GET1^DID(LRSF,LRV2,"","SPECIFIER")
. . . D GLENTRY("*+* MODIFIED REPORT *+*",28,1)
. . . D GLENTRY("(Last modified: ","",1)
. . . S (LRA1,LRB1)=0
. . . F S LRA1=$O(^LR(LRDFN,LRSS,LRI,LRV2,LRA1)) Q:'LRA1 S LRB1=LRA1
. . . Q:'$D(^LR(LRDFN,LRSS,LRI,LRV2,LRB1,0))
. . . S LRSR1=$$GET1^DIQ(LRFILE1,LRB1_","_LRIENS,.01)
. . . S LRSR2=$$GET1^DIQ(LRFILE1,LRB1_","_LRIENS,.02)
. . . S LRTEXT=LRSR1_" typed by "_LRSR2_")"
. . . D GLENTRY(LRTEXT,BTAB)
. . D WP
Q
;
;
SUPRPT ; Supplementary Report
N LRA2
I $P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4) D
. S LRFILE=+$$GET1^DID(LRSF,1.2,"","SPECIFIER")
. S LRIENS1=LRI_","_LRDFN_","
. D GLENTRY("","",1),GLENTRY("SUPPLEMENTARY REPORT(S):","",1)
. S LRV=0 F S LRV=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV)) Q:'LRV D
. . S LRIENS=LRV_","_LRIENS1
. . S LRSR1=$$GET1^DIQ(LRFILE,LRIENS,.01)
. . S LRSR2=+$$GET1^DIQ(LRFILE,LRIENS,.02)
. . D GLENTRY("Supplementary Report Date: "_LRSR1,3,1)
. . I $D(LR("R")),'LRSR2 D GLENTRY(" not verified",BTAB) Q
. . I $P($G(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,0)),U,4) D
. . . S LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED *+*"
. . . D GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1)
. . . D GLENTRY("(Added/Last","",1)
. . . S (LRA1,LRB1)=0
. . . F S LRA1=$O(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,LRA1)) Q:'LRA1 D
. . . . S LRB1=LRA1
. . . Q:'$D(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,LRB1,0))
. . . S LRA2=^(0),Y=+LRA2,LRA2A=$P(LRA2,"^",2),LRSGN=" Typed by ",LRDSC=" modified: "
. . . I $P(LRA2,"^",3) S LRSGN=" Signed by ",LRDSC=" released: ",LRA2A=$P(LRA2,"^",3),Y=$P(LRA2,"^",4)
. . . S LRA2A=$S($D(^VA(200,LRA2A,0)):$P(^(0),"^"),1:LRA2A)
. . . D D^LRU
. . . D GLENTRY(LRDSC_Y_LRSGN_LRA2A_")",BTAB)
. . S LRFLD=1 D WP
. . D GLENTRY("","",1)
Q
;
;
;
N LRB
I '$O(^LR(LRDFN,LRSS,LRI,99,0)) Q
;
D GLENTRY("Comment:","",1)
;
S LRB=0
F S LRB=$O(^LR(LRDFN,LRSS,LRI,99,LRB)) Q:'LRB D
. S LRB(0)=^LR(LRDFN,LRSS,LRI,99,LRB,0)
. D GLENTRY(LRB(0),"",1)
;
D GLENTRY("","",1)
;
Q
;
;
SSJR ; Print special studies/journal references
D ^LRAPBR3
S LREFLG=1
Q
;
;
PPL ; Print performing laboratories.
N LRPL,LRJ
;
D RETLST^LRRPL(.LRPL,LRDFN,LRSS,LRI,0)
I $G(LRPL)<1 Q
;
D GLENTRY("","",1)
D GLENTRY("","",1)
;
D GLENTRY("Performing Laboratory:","",1)
S LRJ=0
F S LRJ=$O(LRPL(LRJ)) Q:'LRJ D GLENTRY(LRPL(LRJ),"",1)
;
D GLENTRY("","",1)
;
Q
;
;
WP ; Display word processing fields
K LRTMP,^UTILITY($J,"W")
N X,DIWR,DIWL,LRINC
S X=$$GET1^DIQ(LRFILE,LRIENS,LRFLD,"","LRTMP",)
S DIWR=IOM-5,DIWL=5,DIWF=$G(DIWF)
S X=+$$GET1^DID(LRFILE,LRFLD,"","SPECIFIER")
I $$GET1^DID(X,.01,"","SPECIFIER")["L",DIWF'["N" S DIWF=DIWF_"N"
I DIWF'["N" S DIWF=DIWF_"N" ;LR*5.2*464
S LRINC=0
F S LRINC=$O(LRTMP(LRINC)) Q:'LRINC S X=LRTMP(LRINC) D ^DIWP
S LRINC=0
F S LRINC=$O(^UTILITY($J,"W",DIWL,LRINC)) Q:'LRINC D GLENTRY(^UTILITY($J,"W",DIWL,LRINC,0),DIWL,1)
K ^UTILITY($J,"W")
Q
;
;
D:LRTIU GLENTRY("$APHDR",,1)
D GLENTRY("","",1)
;
; Print names of facilities printing/releasing this report.
N LRN,LRPL,LRRL,LRX
I $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1,'LRTIU D
. D PFAC^LRRP1(DUZ(2),"",1,.LRPL)
. S LRN=0
. F S LRN=$O(LRPL(LRN)) Q:'LRN D GLENTRY(LRPL(LRN),"",1)
;
; Display reporting lab
I $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2 D
. S LRX=+$G(^LR(LRDFN,LRSS,LRI,"RF"))
. I LRX<1 Q
. D RL^LRRP1(LRX,1,.LRRL),GLENTRY("","",1)
. S LRN=0
. F S LRN=$O(LRRL(LRN)) Q:'LRN D GLENTRY(LRRL(LRN),"",1)
;
D DASH
D GLENTRY("MEDICAL RECORD |",5,1)
D GLENTRY(LRAA1,40)
D DASH
;
;
;
S LRADESC="Accession No. "_$S(LRQ(8)]"":LRQ(8)_LRW(1)_" "_LRAC,1:LRAC)
S LRLENG1=$L(LRQ(1)),LRLENG2=$L(LRADESC),LRSPCE=IOM-LRLENG2-14
S:LRLENG1>LRSPCE LRQ(1)=$E(LRQ(1),1,LRSPCE)
;
D GLENTRY("PATHOLOGY REPORT",30,1)
I '$G(^LR(LRDFN,LRSS,LRI,"RF")) D GLENTRY("Laboratory: "_LRQ(1),"",1)
D GLENTRY(LRADESC,IOM-LRLENG2-1)
Q
;
;
D:LRTIU GLENTRY("$FTR",,1)
D DASH
S LRTEXT=$S('$D(LR("W")):"",1:"See signed copy in chart")
D GLENTRY(LRTEXT,"",1)
S LRTEXT="("_$S($D(LREFLG):"End of report",1:"See next page")_")"
D GLENTRY(LRTEXT,57)
D GLENTRY(LRPMD,"",1),GLENTRY(LRW(9),52),GLENTRY("| Date "_LRRC,55)
D DASH
D GLENTRY(LRP,"",1)
S LRTEXT=$S('$D(LR("W")):"STANDARD FORM 515",1:"WORK COPY ONLY !!")
D GLENTRY(LRTEXT,50)
D GLENTRY("ID:"_SSN,"",1)
D GLENTRY("SEX:"_SEX,16),GLENTRY(" DOB:"_DOB,BTAB)
I AGE D
. S LRTEXT=$S($G(VADM(6))]"":" AGE AT DEATH: ",1:" AGE: ")_AGE
. D GLENTRY(LRTEXT,BTAB)
D GLENTRY(" LOC:"_LRLLOC,BTAB)
D GLENTRY("","",1)
I LRADM'="" D GLENTRY("ADM:"_$P(LRADM,"@"),BTAB)
I LRADX'="" D GLENTRY("DX:"_$E(LRADX,1,26),17)
D GLENTRY("PCP:",46)
I LRPRAC'="" D GLENTRY($E(LRPRAC(1),1,28),51)
Q
;
;
ESIGLN ; Write signature block name, title, and date of signature
D GLENTRY(,,1)
I $D(^VA(200,DUZ,0)) D
. S LRFILE=200,LRFLD=20.2,LRFLD2=20.3
. S X=$$GET1^DIQ(LRFILE,DUZ,LRFLD)
; Compare DUZ to pathologist, if different, use proxy signature
S:LRSS="AU" LRPATH=$$GET1^DIQ(63,LRDFN,13.6,"I")
I LRSS'="AU" D
. S LRFL2=$S(LRSS="EM":63.02,LRSS="CY":63.09,LRSS="SP":63.08,1:0)
. S LRIENS=LRI_","_LRDFN_","
. S LRPATH=$$GET1^DIQ(LRFL2,LRIENS,.02,"I")
S LRPATH2=""
S:LRPATH'=DUZ LRPATH2=" FOR "_$$GET1^DIQ(LRFILE,LRPATH,LRFLD)
S LRTEXT="/es/ "_X_LRPATH2
; S LRTEXT="/es/ "_X
D GLENTRY(LRTEXT,,1)
S LRTEXT=$$GET1^DIQ(LRFILE,DUZ,LRFLD2)
D GLENTRY(LRTEXT,,1)
S LRTEXT="Signed "_$$FMTE^XLFDT(LRNTIME,"1MZ")
D GLENTRY(LRTEXT,,1)
Q
;
;
DASH ; Display a line of dashes
D GLENTRY(LR("%"),"",1)
Q
;
;
GLENTRY(LRPR1,LRPR2,LRPR3) ; Write to global
; LRPR1 = Text to be written to global
; LRPR2 = Tab position
; LRPR3 = 1 means start a new line. Otherwise, write an current line.
S LRPR1=$G(LRPR1)
S LRPR2=+$G(LRPR2)
S LRPR3=+$G(LRPR3)
D:LRPR3 NEWLN^LRAPUTL(LRPR1,LRPR2)
D:'LRPR3 GLBWRT^LRAPUTL(LRPR1,LRPR2)
Q
;
;
TEXT1 ;Text for top of report
;;BRIEF CLINICAL HISTORY:
;;PREOPERATIVE DIAGNOSIS:
;;OPERATIVE FINDINGS:
;;POSTOPERATIVE DIAGNOSIS:
;
TEXT2 ;Descriptive text based on section
;;SP;Pathology Resident:
;;CY;Screened by:
;;EM;Prepared by:
;
FIELDS ;Field numbers for word processing fields
;;1.3;.13;6
;;1;.03;7
;;1.1;.04;4
;;1.4;.14;5
;
TEXTCHK ; update text line counter if it is missing (Remedy 116253)
N I,X,DATA
S I=0
K ^TMP("WP",$J)
S X=$G(^LR(LRDFN,LRSS,LRI,LRV,0))
I X'="",$L(X,"^")=1 D
. F S I=$O(^LR(LRDFN,LRSS,LRI,LRV,I)) Q:I="" D
. . S DATA=$G(^LR(LRDFN,LRSS,LRI,LRV,I,0))
. . S ^TMP("WP",$J,I,0)=DATA
I $D(^TMP("WP",$J)) D
. D WP^DIE(63.08,LRI_","_LRDFN_",",LRV,"","^TMP(""WP"",$J)")
. K ^TMP("WP",$J)
Q
;
;
ATTEND(LRMD) ; Retrieve surgeon/attending
; Call with LRMD = current ordering provider array, pass by reference
;
; Update ordering provider/surgeon if Surgery package indicates change
;
N LRIENS,LRX
S LRIENS=LRDFN_","_LRSS_","_LRI_",0",(LRMD("SR-ATTEND"),LRMD("SR-SURGEON"))=""
S LRX=$O(^LR(LRDFN,"EPR","AD",LRIENS,1,0))
I LRX<1 Q
;
N LRDATA,LRJ,LRORDP,LRREF,LRSRDATA,LRSRTN
S LRREF=LRX_","_LRDFN_","
D GETDATA^LRUEPR(.LRDATA,LRREF)
S LRSRTN=LRDATA(63.00013,LRREF,1,"I")
;
I $P(LRSRTN,";",2)'="SRF(" Q
;
S LRORDP=+$P(^LR(LRDFN,LRSS,LRI,0),"^",7) ; Retrieve current surgeon/provider from file #63
D SRCASE^LRUEPR(.LRSRDATA,+LRSRTN)
;
I $G(LRSRDATA("ERR")) D Q
. S LRMD("ERR")=LRSRDATA("ERR")
. D SRCASERR^LRUEPR(LRREF,LRSRTN,LRSRDATA("ERR"))
;
F LRJ=.14,123 D
. S LRX=LRSRDATA(130,+LRSRTN_",",LRJ,"I")
. I LRX,LRORDP,LRX'=LRORDP S LRMD("SR-SURGEON")=$S(LRJ=.14:" Current Surgeon",LRJ=123:"Current Provider",1:"")_": "_$$NAME^XUSER(LRX,"G")
F LRJ=.164,124 D
. S LRX=LRSRDATA(130,+LRSRTN_",",LRJ,"I")
. I LRX S LRMD("SR-ATTEND")=$S(LRJ=.164:" Attending Surgeon",LRJ=124:"Attending Provider",1:"")_": "_$$NAME^XUSER(LRX,"G")
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPBR1 11676 printed Sep 23, 2025@19:42:39 Page 2
LRAPBR1 ;DALOI/STAFF - AP Browser Print Cont. ; 26 Jul 2016 5:01 PM
+1 ;;5.2;LAB SERVICE;**259,317,363,350,427,464**;Sep 27, 1994;Build 12
+2 ;
+3 ;
ENTER ; from LRAPBR
+1 NEW LRCNT,LRTMP,LRA1,LRADESC,LRLENG1,LRLENG2,LRFILE,LRAPMD
+2 NEW LRFLD,LRV,LRV1,LRV2,LRX,LRB1,LRTEXT,LRSPCE,LRIENS,LRAPMR
+3 if '$DATA(^LR(LRDFN,LRSS,LRI,0))
QUIT
+4 if 'LRTIU
SET GROOT="^TMP(""LRAPBR"",$J,"
+5 if LRTIU
SET GROOT="^TMP(""TIUP"",$J,"
+6 ;
+7 DO GETPCP^LRAPUTL(.LRPRAC,LRDFN,LRSS,LRI)
+8 ;
+9 ; If reporting lab available then use instead of VistA site name.
+10 SET LRX=+$GET(^LR(LRDFN,LRSS,LRI,"RF"))
+11 IF LRX
SET LRQ(1)=$$NAME^XUAF4(LRX)
+12 ;
+13 SET LRQ=0
DO ^LRUA
DO HEADER
+14 SET LR("F")=1
+15 DO DASH
+16 if LRTIU
DO GLENTRY("$TEXT",,1)
+17 DO GLENTRY("Submitted by: "_LRW(5),"",1)
+18 DO GLENTRY("Date obtained: "_LRTK,44)
+19 if LRA
DO DASH
+20 ;
+21 SET LRIENS=LRI_","_LRDFN_","
+22 ;
+23 ;
MAIN ;
+1 DO SPEC
+2 DO MODCHK
+3 DO SUPBNNR
+4 ; DALOI/LMT - LR,427 - Removed comments from report to restore pre-LR,350 behavior
+5 ;D COMMENT
+6 DO DIAG
+7 DO DOC
+8 DO WPFLD
+9 DO SUPRPT
+10 DO SSJR
+11 QUIT
+12 ;
+13 ;
SPEC ; List specimens
+1 ;
+2 ;ZEXCEPT: LRDFN,LRI,LRIENS,LRSF,LRSS
+3 ;
+4 NEW LRB,LRFILE,LRX
+5 ;
+6 DO GLENTRY("Specimen (Received "_LRTK(1)_"):","",1)
+7 ;
+8 SET LRFILE=+$$GET1^DID(LRSF,.012,"","SPECIFIER")
+9 SET LRB=0
+10 FOR
SET LRB=$ORDER(^LR(LRDFN,LRSS,LRI,.1,LRB))
if LRB<1
QUIT
Begin DoDot:1
+11 SET LRX=$$GET1^DIQ(LRFILE,LRB_","_LRIENS,.01)
+12 DO GLENTRY(LRX,"",1)
End DoDot:1
+13 ;
+14 QUIT
+15 ;
+16 ;
MODCHK ; Display modified banner if required
+1 SET LRAPMR=$$GET1^DIQ(LRSF,LRIENS,.17,"I")
+2 if 'LRAPMR
QUIT
+3 SET LRAPMD=$$GET1^DIQ(LRSF,LRIENS,.172,"I")
+4 DO GLENTRY("","",1)
+5 SET LRTEXT=""
+6 FOR LRCNT=1:1:$SELECT(LRAPMD:14,1:15)
Begin DoDot:1
+7 SET LRTEXT=LRTEXT_"*+"
End DoDot:1
+8 SET LRTEXT=LRTEXT_" MODIFIED "
+9 SET LRTEXT=LRTEXT_$SELECT(LRAPMD:"DIAGNOSIS ",1:"REPORT ")
+10 FOR LRCNT=1:1:$SELECT(LRAPMD:14,1:15)
Begin DoDot:1
+11 SET LRTEXT=LRTEXT_"*+"
End DoDot:1
+12 DO GLENTRY(LRTEXT,"",1)
+13 DO GLENTRY("","",1)
+14 QUIT
+15 ;
+16 ;
SUPBNNR ; Display supplementary report header if one or more has been added
+1 IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4)
Begin DoDot:1
+2 SET LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED *+*"
+3 DO GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1)
+4 SET LRTEXT="*+* REFER TO BOTTOM OF REPORT *+*"
+5 DO GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1)
+6 DO GLENTRY("","",1)
End DoDot:1
+7 QUIT
+8 ;
+9 ;
DIAG ; Display the Brief Clinical History, Preoperative Diagnosis, Operative Findings, and Postoperative Diagnosis
+1 SET LRFILE=LRSF
SET LRCNT=0
SET LRIENS=LRI_","_LRDFN_","
+2 FOR LRFLD=.013:.001:.016
Begin DoDot:1
+3 if LRA
DO DASH
+4 SET LRCNT=LRCNT+1
+5 DO GLENTRY($PIECE($TEXT(TEXT1+LRCNT),";",3),"",1)
+6 DO WP
End DoDot:1
+7 QUIT
+8 ;
+9 ;
DOC ; Pathologist information
+1 ;
+2 NEW LRIENS,LRX
+3 DO GLENTRY("","",1)
+4 ;
+5 ; Retrieve surgeon/attending
+6 DO ATTEND(.LRMD)
+7 DO GLENTRY("Surgeon/physician: "_LRMD,27,1)
+8 IF LRMD("SR-SURGEON")'=""
DO GLENTRY(LRMD("SR-SURGEON"),28,1)
+9 IF LRMD("SR-ATTEND")'=""
DO GLENTRY(LRMD("SR-ATTEND"),26,1)
+10 ;I +$G(LRMD("ERR"))=601 D GLENTRY($P(LRMD("ERR"),"^",2),26,1)
+11 ;
+12 if LRA
DO GLENTRY(LR("%1"),"",1)
+13 DO DASH
+14 DO HEADER2
+15 if LRA
DO DASH
+16 IF LRRC=""
Begin DoDot:1
+17 DO GLENTRY("+*+* REPORT INCOMPLETE *+*+",20,1)
+18 DO GLENTRY("","",1)
End DoDot:1
+19 DO GLENTRY("","",1)
+20 IF LRRMD'=""
Begin DoDot:1
+21 SET LRCNT=0
FOR LRA1="SP","CY","EM"
Begin DoDot:2
+22 SET LRCNT=LRCNT+1
+23 SET LRTMP(LRA1)=$PIECE($TEXT(TEXT2+LRCNT),";",4)
End DoDot:2
+24 SET LRTMP=LRTMP(LRSS)
+25 DO GLENTRY(LRTMP_" "_LRRMD,31)
End DoDot:1
+26 QUIT
+27 ;
+28 ;
WPFLD ; Display Frozen Section, Gross Description, Microscopic Description and Surgical Path Diagnosis
+1 FOR LRCNT=1:1:4
Begin DoDot:1
+2 SET X=$TEXT(FIELDS+LRCNT)
+3 SET LRV=$PIECE(X,";",3)
SET LRV1=$PIECE(X,";",4)
SET LRV2=$PIECE(X,";",5)
+4 DO TEXTCHK
+5 IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,LRV,0)),U,4)
Begin DoDot:2
+6 DO GLENTRY("","",1)
DO GLENTRY(LR(69.2,LRV1),"",1)
+7 SET LRFILE=LRSF
SET LRIENS=LRI_","_LRDFN_","
SET LRFLD=LRV
+8 IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,LRV2,0)),U,4)
Begin DoDot:3
+9 SET LRFILE1=+$$GET1^DID(LRSF,LRV2,"","SPECIFIER")
+10 DO GLENTRY("*+* MODIFIED REPORT *+*",28,1)
+11 DO GLENTRY("(Last modified: ","",1)
+12 SET (LRA1,LRB1)=0
+13 FOR
SET LRA1=$ORDER(^LR(LRDFN,LRSS,LRI,LRV2,LRA1))
if 'LRA1
QUIT
SET LRB1=LRA1
+14 if '$DATA(^LR(LRDFN,LRSS,LRI,LRV2,LRB1,0))
QUIT
+15 SET LRSR1=$$GET1^DIQ(LRFILE1,LRB1_","_LRIENS,.01)
+16 SET LRSR2=$$GET1^DIQ(LRFILE1,LRB1_","_LRIENS,.02)
+17 SET LRTEXT=LRSR1_" typed by "_LRSR2_")"
+18 DO GLENTRY(LRTEXT,BTAB)
End DoDot:3
+19 DO WP
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
+22 ;
SUPRPT ; Supplementary Report
+1 NEW LRA2
+2 IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4)
Begin DoDot:1
+3 SET LRFILE=+$$GET1^DID(LRSF,1.2,"","SPECIFIER")
+4 SET LRIENS1=LRI_","_LRDFN_","
+5 DO GLENTRY("","",1)
DO GLENTRY("SUPPLEMENTARY REPORT(S):","",1)
+6 SET LRV=0
FOR
SET LRV=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV))
if 'LRV
QUIT
Begin DoDot:2
+7 SET LRIENS=LRV_","_LRIENS1
+8 SET LRSR1=$$GET1^DIQ(LRFILE,LRIENS,.01)
+9 SET LRSR2=+$$GET1^DIQ(LRFILE,LRIENS,.02)
+10 DO GLENTRY("Supplementary Report Date: "_LRSR1,3,1)
+11 IF $DATA(LR("R"))
IF 'LRSR2
DO GLENTRY(" not verified",BTAB)
QUIT
+12 IF $PIECE($GET(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,0)),U,4)
Begin DoDot:3
+13 SET LRTEXT="*+* SUPPLEMENTARY REPORT HAS BEEN ADDED/MODIFIED *+*"
+14 DO GLENTRY($$CJ^XLFSTR(LRTEXT,IOM),"",1)
+15 DO GLENTRY("(Added/Last","",1)
+16 SET (LRA1,LRB1)=0
+17 FOR
SET LRA1=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,LRA1))
if 'LRA1
QUIT
Begin DoDot:4
+18 SET LRB1=LRA1
End DoDot:4
+19 if '$DATA(^LR(LRDFN,LRSS,LRI,1.2,LRV,2,LRB1,0))
QUIT
+20 SET LRA2=^(0)
SET Y=+LRA2
SET LRA2A=$PIECE(LRA2,"^",2)
SET LRSGN=" Typed by "
SET LRDSC=" modified: "
+21 IF $PIECE(LRA2,"^",3)
SET LRSGN=" Signed by "
SET LRDSC=" released: "
SET LRA2A=$PIECE(LRA2,"^",3)
SET Y=$PIECE(LRA2,"^",4)
+22 SET LRA2A=$SELECT($DATA(^VA(200,LRA2A,0)):$PIECE(^(0),"^"),1:LRA2A)
+23 DO D^LRU
+24 DO GLENTRY(LRDSC_Y_LRSGN_LRA2A_")",BTAB)
End DoDot:3
+25 SET LRFLD=1
DO WP
+26 DO GLENTRY("","",1)
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
+29 ;
+1 ;
+2 NEW LRB
+3 IF '$ORDER(^LR(LRDFN,LRSS,LRI,99,0))
QUIT
+4 ;
+5 DO GLENTRY("Comment:","",1)
+6 ;
+7 SET LRB=0
+8 FOR
SET LRB=$ORDER(^LR(LRDFN,LRSS,LRI,99,LRB))
if 'LRB
QUIT
Begin DoDot:1
+9 SET LRB(0)=^LR(LRDFN,LRSS,LRI,99,LRB,0)
+10 DO GLENTRY(LRB(0),"",1)
End DoDot:1
+11 ;
+12 DO GLENTRY("","",1)
+13 ;
+14 QUIT
+15 ;
+16 ;
SSJR ; Print special studies/journal references
+1 DO ^LRAPBR3
+2 SET LREFLG=1
+3 QUIT
+4 ;
+5 ;
PPL ; Print performing laboratories.
+1 NEW LRPL,LRJ
+2 ;
+3 DO RETLST^LRRPL(.LRPL,LRDFN,LRSS,LRI,0)
+4 IF $GET(LRPL)<1
QUIT
+5 ;
+6 DO GLENTRY("","",1)
+7 DO GLENTRY("","",1)
+8 ;
+9 DO GLENTRY("Performing Laboratory:","",1)
+10 SET LRJ=0
+11 FOR
SET LRJ=$ORDER(LRPL(LRJ))
if 'LRJ
QUIT
DO GLENTRY(LRPL(LRJ),"",1)
+12 ;
+13 DO GLENTRY("","",1)
+14 ;
+15 QUIT
+16 ;
+17 ;
WP ; Display word processing fields
+1 KILL LRTMP,^UTILITY($JOB,"W")
+2 NEW X,DIWR,DIWL,LRINC
+3 SET X=$$GET1^DIQ(LRFILE,LRIENS,LRFLD,"","LRTMP",)
+4 SET DIWR=IOM-5
SET DIWL=5
SET DIWF=$GET(DIWF)
+5 SET X=+$$GET1^DID(LRFILE,LRFLD,"","SPECIFIER")
+6 IF $$GET1^DID(X,.01,"","SPECIFIER")["L"
IF DIWF'["N"
SET DIWF=DIWF_"N"
+7 ;LR*5.2*464
IF DIWF'["N"
SET DIWF=DIWF_"N"
+8 SET LRINC=0
+9 FOR
SET LRINC=$ORDER(LRTMP(LRINC))
if 'LRINC
QUIT
SET X=LRTMP(LRINC)
DO ^DIWP
+10 SET LRINC=0
+11 FOR
SET LRINC=$ORDER(^UTILITY($JOB,"W",DIWL,LRINC))
if 'LRINC
QUIT
DO GLENTRY(^UTILITY($JOB,"W",DIWL,LRINC,0),DIWL,1)
+12 KILL ^UTILITY($JOB,"W")
+13 QUIT
+14 ;
+15 ;
+1 if LRTIU
DO GLENTRY("$APHDR",,1)
+2 DO GLENTRY("","",1)
+3 ;
+4 ; Print names of facilities printing/releasing this report.
+5 NEW LRN,LRPL,LRRL,LRX
+6 IF $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1
IF 'LRTIU
Begin DoDot:1
+7 DO PFAC^LRRP1(DUZ(2),"",1,.LRPL)
+8 SET LRN=0
+9 FOR
SET LRN=$ORDER(LRPL(LRN))
if 'LRN
QUIT
DO GLENTRY(LRPL(LRN),"",1)
End DoDot:1
+10 ;
+11 ; Display reporting lab
+12 IF $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2
Begin DoDot:1
+13 SET LRX=+$GET(^LR(LRDFN,LRSS,LRI,"RF"))
+14 IF LRX<1
QUIT
+15 DO RL^LRRP1(LRX,1,.LRRL)
DO GLENTRY("","",1)
+16 SET LRN=0
+17 FOR
SET LRN=$ORDER(LRRL(LRN))
if 'LRN
QUIT
DO GLENTRY(LRRL(LRN),"",1)
End DoDot:1
+18 ;
+19 DO DASH
+20 DO GLENTRY("MEDICAL RECORD |",5,1)
+21 DO GLENTRY(LRAA1,40)
+22 DO DASH
+23 ;
+24 ;
+1 ;
+2 SET LRADESC="Accession No. "_$SELECT(LRQ(8)]"":LRQ(8)_LRW(1)_" "_LRAC,1:LRAC)
+3 SET LRLENG1=$LENGTH(LRQ(1))
SET LRLENG2=$LENGTH(LRADESC)
SET LRSPCE=IOM-LRLENG2-14
+4 if LRLENG1>LRSPCE
SET LRQ(1)=$EXTRACT(LRQ(1),1,LRSPCE)
+5 ;
+6 DO GLENTRY("PATHOLOGY REPORT",30,1)
+7 IF '$GET(^LR(LRDFN,LRSS,LRI,"RF"))
DO GLENTRY("Laboratory: "_LRQ(1),"",1)
+8 DO GLENTRY(LRADESC,IOM-LRLENG2-1)
+9 QUIT
+10 ;
+11 ;
+1 if LRTIU
DO GLENTRY("$FTR",,1)
+2 DO DASH
+3 SET LRTEXT=$SELECT('$DATA(LR("W")):"",1:"See signed copy in chart")
+4 DO GLENTRY(LRTEXT,"",1)
+5 SET LRTEXT="("_$SELECT($DATA(LREFLG):"End of report",1:"See next page")_")"
+6 DO GLENTRY(LRTEXT,57)
+7 DO GLENTRY(LRPMD,"",1)
DO GLENTRY(LRW(9),52)
DO GLENTRY("| Date "_LRRC,55)
+8 DO DASH
+9 DO GLENTRY(LRP,"",1)
+10 SET LRTEXT=$SELECT('$DATA(LR("W")):"STANDARD FORM 515",1:"WORK COPY ONLY !!")
+11 DO GLENTRY(LRTEXT,50)
+12 DO GLENTRY("ID:"_SSN,"",1)
+13 DO GLENTRY("SEX:"_SEX,16)
DO GLENTRY(" DOB:"_DOB,BTAB)
+14 IF AGE
Begin DoDot:1
+15 SET LRTEXT=$SELECT($GET(VADM(6))]"":" AGE AT DEATH: ",1:" AGE: ")_AGE
+16 DO GLENTRY(LRTEXT,BTAB)
End DoDot:1
+17 DO GLENTRY(" LOC:"_LRLLOC,BTAB)
+18 DO GLENTRY("","",1)
+19 IF LRADM'=""
DO GLENTRY("ADM:"_$PIECE(LRADM,"@"),BTAB)
+20 IF LRADX'=""
DO GLENTRY("DX:"_$EXTRACT(LRADX,1,26),17)
+21 DO GLENTRY("PCP:",46)
+22 IF LRPRAC'=""
DO GLENTRY($EXTRACT(LRPRAC(1),1,28),51)
+23 QUIT
+24 ;
+25 ;
ESIGLN ; Write signature block name, title, and date of signature
+1 DO GLENTRY(,,1)
+2 IF $DATA(^VA(200,DUZ,0))
Begin DoDot:1
+3 SET LRFILE=200
SET LRFLD=20.2
SET LRFLD2=20.3
+4 SET X=$$GET1^DIQ(LRFILE,DUZ,LRFLD)
End DoDot:1
+5 ; Compare DUZ to pathologist, if different, use proxy signature
+6 if LRSS="AU"
SET LRPATH=$$GET1^DIQ(63,LRDFN,13.6,"I")
+7 IF LRSS'="AU"
Begin DoDot:1
+8 SET LRFL2=$SELECT(LRSS="EM":63.02,LRSS="CY":63.09,LRSS="SP":63.08,1:0)
+9 SET LRIENS=LRI_","_LRDFN_","
+10 SET LRPATH=$$GET1^DIQ(LRFL2,LRIENS,.02,"I")
End DoDot:1
+11 SET LRPATH2=""
+12 if LRPATH'=DUZ
SET LRPATH2=" FOR "_$$GET1^DIQ(LRFILE,LRPATH,LRFLD)
+13 SET LRTEXT="/es/ "_X_LRPATH2
+14 ; S LRTEXT="/es/ "_X
+15 DO GLENTRY(LRTEXT,,1)
+16 SET LRTEXT=$$GET1^DIQ(LRFILE,DUZ,LRFLD2)
+17 DO GLENTRY(LRTEXT,,1)
+18 SET LRTEXT="Signed "_$$FMTE^XLFDT(LRNTIME,"1MZ")
+19 DO GLENTRY(LRTEXT,,1)
+20 QUIT
+21 ;
+22 ;
DASH ; Display a line of dashes
+1 DO GLENTRY(LR("%"),"",1)
+2 QUIT
+3 ;
+4 ;
GLENTRY(LRPR1,LRPR2,LRPR3) ; Write to global
+1 ; LRPR1 = Text to be written to global
+2 ; LRPR2 = Tab position
+3 ; LRPR3 = 1 means start a new line. Otherwise, write an current line.
+4 SET LRPR1=$GET(LRPR1)
+5 SET LRPR2=+$GET(LRPR2)
+6 SET LRPR3=+$GET(LRPR3)
+7 if LRPR3
DO NEWLN^LRAPUTL(LRPR1,LRPR2)
+8 if 'LRPR3
DO GLBWRT^LRAPUTL(LRPR1,LRPR2)
+9 QUIT
+10 ;
+11 ;
TEXT1 ;Text for top of report
+1 ;;BRIEF CLINICAL HISTORY:
+2 ;;PREOPERATIVE DIAGNOSIS:
+3 ;;OPERATIVE FINDINGS:
+4 ;;POSTOPERATIVE DIAGNOSIS:
+5 ;
TEXT2 ;Descriptive text based on section
+1 ;;SP;Pathology Resident:
+2 ;;CY;Screened by:
+3 ;;EM;Prepared by:
+4 ;
FIELDS ;Field numbers for word processing fields
+1 ;;1.3;.13;6
+2 ;;1;.03;7
+3 ;;1.1;.04;4
+4 ;;1.4;.14;5
+5 ;
TEXTCHK ; update text line counter if it is missing (Remedy 116253)
+1 NEW I,X,DATA
+2 SET I=0
+3 KILL ^TMP("WP",$JOB)
+4 SET X=$GET(^LR(LRDFN,LRSS,LRI,LRV,0))
+5 IF X'=""
IF $LENGTH(X,"^")=1
Begin DoDot:1
+6 FOR
SET I=$ORDER(^LR(LRDFN,LRSS,LRI,LRV,I))
if I=""
QUIT
Begin DoDot:2
+7 SET DATA=$GET(^LR(LRDFN,LRSS,LRI,LRV,I,0))
+8 SET ^TMP("WP",$JOB,I,0)=DATA
End DoDot:2
End DoDot:1
+9 IF $DATA(^TMP("WP",$JOB))
Begin DoDot:1
+10 DO WP^DIE(63.08,LRI_","_LRDFN_",",LRV,"","^TMP(""WP"",$J)")
+11 KILL ^TMP("WP",$JOB)
End DoDot:1
+12 QUIT
+13 ;
+14 ;
ATTEND(LRMD) ; Retrieve surgeon/attending
+1 ; Call with LRMD = current ordering provider array, pass by reference
+2 ;
+3 ; Update ordering provider/surgeon if Surgery package indicates change
+4 ;
+5 NEW LRIENS,LRX
+6 SET LRIENS=LRDFN_","_LRSS_","_LRI_",0"
SET (LRMD("SR-ATTEND"),LRMD("SR-SURGEON"))=""
+7 SET LRX=$ORDER(^LR(LRDFN,"EPR","AD",LRIENS,1,0))
+8 IF LRX<1
QUIT
+9 ;
+10 NEW LRDATA,LRJ,LRORDP,LRREF,LRSRDATA,LRSRTN
+11 SET LRREF=LRX_","_LRDFN_","
+12 DO GETDATA^LRUEPR(.LRDATA,LRREF)
+13 SET LRSRTN=LRDATA(63.00013,LRREF,1,"I")
+14 ;
+15 IF $PIECE(LRSRTN,";",2)'="SRF("
QUIT
+16 ;
+17 ; Retrieve current surgeon/provider from file #63
SET LRORDP=+$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",7)
+18 DO SRCASE^LRUEPR(.LRSRDATA,+LRSRTN)
+19 ;
+20 IF $GET(LRSRDATA("ERR"))
Begin DoDot:1
+21 SET LRMD("ERR")=LRSRDATA("ERR")
+22 DO SRCASERR^LRUEPR(LRREF,LRSRTN,LRSRDATA("ERR"))
End DoDot:1
QUIT
+23 ;
+24 FOR LRJ=.14,123
Begin DoDot:1
+25 SET LRX=LRSRDATA(130,+LRSRTN_",",LRJ,"I")
+26 IF LRX
IF LRORDP
IF LRX'=LRORDP
SET LRMD("SR-SURGEON")=$SELECT(LRJ=.14:" Current Surgeon",LRJ=123:"Current Provider",1:"")_": "_$$NAME^XUSER(LRX,"G")
End DoDot:1
+27 FOR LRJ=.164,124
Begin DoDot:1
+28 SET LRX=LRSRDATA(130,+LRSRTN_",",LRJ,"I")
+29 IF LRX
SET LRMD("SR-ATTEND")=$SELECT(LRJ=.164:" Attending Surgeon",LRJ=124:"Attending Provider",1:"")_": "_$$NAME^XUSER(LRX,"G")
End DoDot:1
+30 ;
+31 QUIT
