LRAPBR2 ;DALOI/WTY/KLL - AP Browser Print ;04/04/01
;;5.2;LAB SERVICE;**259**;Sep 27, 1994
;
; This routine is a modified version of LRAPT1 to be used for
; browser display.
;
N LRSS,LRI,LRPATH,LRIENS,LRACN,LRRLDTE,LRRCDTE
N LRTEXT,LRI1,LRI2,LRIENS1,LRSPC
S LR("F")=1
F LRSS="SP","CY","EM" D
.Q:'+$P($G(^LR(LRDFN,LRSS,0)),"^",4)
.S LRTMP=""
.S:LRSS="SP" LRTMP="SURGICAL PATHOLOGY",(LRFILE,LRXF)=63.08
.S:LRSS="CY" LRTMP="CYTOPATHOLOGY",(LRFILE,LRXF)=63.09
.S:LRSS="EM" LRTMP="ELECTRON MICROSCOPY",(LRFILE,LRXF)=63.02
.D GLENTRY("","",1),GLENTRY(LRTMP,30,1)
.K LRTMP
.S LRI=0 F S LRI=$O(^LR(LRDFN,LRSS,LRI)) Q:'LRI D
..S LRIENS=LRI_","_LRDFN_","
..S LRPATH=$E($$GET1^DIQ(LRFILE,LRIENS,.02,""),1,12)
..S LRACN=$$GET1^DIQ(LRFILE,LRIENS,.06,"")
..S:LRACN="" LRACN="?"
..S LRRLDTE=$$GET1^DIQ(LRFILE,LRIENS,.11,"")
..S LRRCDTE=$$FMTE^XLFDT($$GET1^DIQ(LRFILE,LRIENS,.1,"I"),"D")
..D GLENTRY("Organ/tissue:",2,1)
..D GLENTRY("Date rec'd: "_LRRCDTE,17)
..D GLENTRY("Acc #:"_LRACN,43)
..D GLENTRY(LRPATH,64)
..I LRRLDTE="" D GLENTRY("Report not verified.",5,1)
..;KLL - Display Snomed Codes on report in Browser
..D GETSNMD
..Q:LRRLDTE=""
..;Special Studies
..S LRFILE1=+$$GET1^DID(LRFILE,10,"","SPECIFIER")
..S LRI1=0 F S LRI1=$O(^LR(LRDFN,LRSS,LRI,2,LRI1)) Q:'LRI1 D
...S LRFILE2=+$$GET1^DID(LRFILE1,5,"","SPECIFIER")
...S LRI2=0 F S LRI2=$O(^LR(LRDFN,LRSS,LRI,2,LRI1,5,LRI2)) Q:'LRI2 D
....S LRIENS1=LRI2_","_LRI1_","_LRIENS
....D GETS^DIQ(LRFILE2,LRIENS1,".01;.03","","LRARR")
....M LRSPC=LRARR(LRFILE2,LRIENS1)
....S LRSPC(.02)=$$GET1^DIQ(LRFILE2,LRIENS1,.02,"E")
....S LRTEXT=LRSPC(.01)_" "_LRSPC(.03)_" Date: "_LRSPC(.02)
....D GLENTRY(LRTEXT,5,1)
Q
GETSNMD ;Retrieve SNOMED codes, desc. for display to Browser
S LRQUIT=0
D CHKSNMD
Q:LRQUIT
I LRAU D
.S LRFIL="^LR(LRDFN,""AY"",",LRFILE1=63.2,LRIENS=LRDFN_",",LRCASE=1
I 'LRAU D
.S LRFIL="^LR(LRDFN,LRSS,LRI,2,"
.S LRFILE1=+$$GET1^DID(LRFILE,10,"","SPECIFIER")
.S LRIENS=LRI_","_LRDFN_","
.S LRCASE=+$$GET1^DIQ(69.2,LRAA_",",.05,"I")
S LRA=0 F S LRA=$O(@(LRFIL_"LRA)")) Q:LRA'>0!(LRQUIT) D
.;Topography
.S LRIENS1=LRA_","_LRIENS
.D WRTSNMD(LRFILE1,LRIENS1,LRCASE,"T",0)
.;Morphology
.S LRA1=0
.F S LRA1=$O(@(LRFIL_"LRA,2,LRA1)")) Q:LRA1'>0!(LRQUIT) D
..S LRFILE2=+$$GET1^DID(LRFILE1,4,"","SPECIFIER")
..S LRIENS2=LRA1_","_LRIENS1
..D WRTSNMD(LRFILE2,LRIENS2,LRCASE,"M",5)
..;Etiology
..S LRA2=0
..F S LRA2=$O(@(LRFIL_"LRA,2,LRA1,1,LRA2)")) Q:LRA2'>0!(LRQUIT) D
...S LRFILE3=+$$GET1^DID(LRFILE2,1,"","SPECIFIER")
...S LRIENS3=LRA2_","_LRIENS2
...D WRTSNMD(LRFILE3,LRIENS3,LRCASE,"E",10)
.;Disease,Function,Procedure
.F LRDFP="1;3","3;1","4;1.5" D
..S LRDFP(1)=$P(LRDFP,";"),LRDFP(2)=$P(LRDFP,";",2),LRA1=0
..F S LRA1=$O(@(LRFIL_"LRA,LRDFP(1),LRA1)")) Q:LRA1'>0!(LRQUIT) D
...S LRFILE2=+$$GET1^DID(LRFILE1,LRDFP(2),"","SPECIFIER")
...S LRIENS2=LRA1_","_LRIENS1
...S LRPRFX=$S(LRDFP(1)=1:"D",LRDFP(1)=3:"F",1:"P")
...D WRTSNMD(LRFILE2,LRIENS2,LRCASE,LRPRFX,5)
Q
CHKSNMD ;Check for SNOMED codes on the accession
N LRSB
I LRAU D Q
.S LRSB=$Q(^LR(LRDFN,"AY",0))
.I $QS(LRSB,2)'="AY" S LRQUIT=1
S LRSB=$Q(^LR(LRDFN,LRSS,LRI,2,0))
I $QS(LRSB,4)'=2 S LRQUIT=1
Q
WRTSNMD(LRP1,LRP2,LRP3,LRP4,LRP5) ;
;LRP1=File number
;LRP2=IEN string
;LRP3=Case (Upper or Lower)
;LRP4=Prefix
;LRP5=Tab position
N LRSM
S LRSM(1)=$$GET1^DIQ(LRP1,LRP2,.01)
S:LRP3 LRSM(1)=$$LOW^XLFSTR(LRSM(1))
S LRSM(2)=LRP4_"-"_$$GET1^DIQ(LRP1,LRP2,".01:2")
S LRTXT=LRSM(2)_": "_LRSM(1)
I LRP4="P" D
.S LRSM(3)=$$GET1^DIQ(LRP1,LRP2,.02,"I")
.I LRSM(3)'="" S LRTXT=LRTXT_" ("_$S('LRSM(3):"negative",LRSM(3)=1:"positive",1:"?")_")"
D GLENTRY(LRTXT,LRP5,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. Othewise, write an current line.
S LRPR3=+$G(LRPR3)
D:LRPR3 NEWLN^LRAPUTL(LRPR1,LRPR2)
D:'LRPR3 GLBWRT^LRAPUTL(LRPR1,LRPR2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPBR2 4059 printed Apr 09, 2024@21:22:20 Page 2
LRAPBR2 ;DALOI/WTY/KLL - AP Browser Print ;04/04/01
+1 ;;5.2;LAB SERVICE;**259**;Sep 27, 1994
+2 ;
+3 ; This routine is a modified version of LRAPT1 to be used for
+4 ; browser display.
+5 ;
+6 NEW LRSS,LRI,LRPATH,LRIENS,LRACN,LRRLDTE,LRRCDTE
+7 NEW LRTEXT,LRI1,LRI2,LRIENS1,LRSPC
+8 SET LR("F")=1
+9 FOR LRSS="SP","CY","EM"
Begin DoDot:1
+10 if '+$PIECE($GET(^LR(LRDFN,LRSS,0)),"^",4)
QUIT
+11 SET LRTMP=""
+12 if LRSS="SP"
SET LRTMP="SURGICAL PATHOLOGY"
SET (LRFILE,LRXF)=63.08
+13 if LRSS="CY"
SET LRTMP="CYTOPATHOLOGY"
SET (LRFILE,LRXF)=63.09
+14 if LRSS="EM"
SET LRTMP="ELECTRON MICROSCOPY"
SET (LRFILE,LRXF)=63.02
+15 DO GLENTRY("","",1)
DO GLENTRY(LRTMP,30,1)
+16 KILL LRTMP
+17 SET LRI=0
FOR
SET LRI=$ORDER(^LR(LRDFN,LRSS,LRI))
if 'LRI
QUIT
Begin DoDot:2
+18 SET LRIENS=LRI_","_LRDFN_","
+19 SET LRPATH=$EXTRACT($$GET1^DIQ(LRFILE,LRIENS,.02,""),1,12)
+20 SET LRACN=$$GET1^DIQ(LRFILE,LRIENS,.06,"")
+21 if LRACN=""
SET LRACN="?"
+22 SET LRRLDTE=$$GET1^DIQ(LRFILE,LRIENS,.11,"")
+23 SET LRRCDTE=$$FMTE^XLFDT($$GET1^DIQ(LRFILE,LRIENS,.1,"I"),"D")
+24 DO GLENTRY("Organ/tissue:",2,1)
+25 DO GLENTRY("Date rec'd: "_LRRCDTE,17)
+26 DO GLENTRY("Acc #:"_LRACN,43)
+27 DO GLENTRY(LRPATH,64)
+28 IF LRRLDTE=""
DO GLENTRY("Report not verified.",5,1)
+29 ;KLL - Display Snomed Codes on report in Browser
+30 DO GETSNMD
+31 if LRRLDTE=""
QUIT
+32 ;Special Studies
+33 SET LRFILE1=+$$GET1^DID(LRFILE,10,"","SPECIFIER")
+34 SET LRI1=0
FOR
SET LRI1=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRI1))
if 'LRI1
QUIT
Begin DoDot:3
+35 SET LRFILE2=+$$GET1^DID(LRFILE1,5,"","SPECIFIER")
+36 SET LRI2=0
FOR
SET LRI2=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRI1,5,LRI2))
if 'LRI2
QUIT
Begin DoDot:4
+37 SET LRIENS1=LRI2_","_LRI1_","_LRIENS
+38 DO GETS^DIQ(LRFILE2,LRIENS1,".01;.03","","LRARR")
+39 MERGE LRSPC=LRARR(LRFILE2,LRIENS1)
+40 SET LRSPC(.02)=$$GET1^DIQ(LRFILE2,LRIENS1,.02,"E")
+41 SET LRTEXT=LRSPC(.01)_" "_LRSPC(.03)_" Date: "_LRSPC(.02)
+42 DO GLENTRY(LRTEXT,5,1)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+43 QUIT
GETSNMD ;Retrieve SNOMED codes, desc. for display to Browser
+1 SET LRQUIT=0
+2 DO CHKSNMD
+3 if LRQUIT
QUIT
+4 IF LRAU
Begin DoDot:1
+5 SET LRFIL="^LR(LRDFN,""AY"","
SET LRFILE1=63.2
SET LRIENS=LRDFN_","
SET LRCASE=1
End DoDot:1
+6 IF 'LRAU
Begin DoDot:1
+7 SET LRFIL="^LR(LRDFN,LRSS,LRI,2,"
+8 SET LRFILE1=+$$GET1^DID(LRFILE,10,"","SPECIFIER")
+9 SET LRIENS=LRI_","_LRDFN_","
+10 SET LRCASE=+$$GET1^DIQ(69.2,LRAA_",",.05,"I")
End DoDot:1
+11 SET LRA=0
FOR
SET LRA=$ORDER(@(LRFIL_"LRA)"))
if LRA'>0!(LRQUIT)
QUIT
Begin DoDot:1
+12 ;Topography
+13 SET LRIENS1=LRA_","_LRIENS
+14 DO WRTSNMD(LRFILE1,LRIENS1,LRCASE,"T",0)
+15 ;Morphology
+16 SET LRA1=0
+17 FOR
SET LRA1=$ORDER(@(LRFIL_"LRA,2,LRA1)"))
if LRA1'>0!(LRQUIT)
QUIT
Begin DoDot:2
+18 SET LRFILE2=+$$GET1^DID(LRFILE1,4,"","SPECIFIER")
+19 SET LRIENS2=LRA1_","_LRIENS1
+20 DO WRTSNMD(LRFILE2,LRIENS2,LRCASE,"M",5)
+21 ;Etiology
+22 SET LRA2=0
+23 FOR
SET LRA2=$ORDER(@(LRFIL_"LRA,2,LRA1,1,LRA2)"))
if LRA2'>0!(LRQUIT)
QUIT
Begin DoDot:3
+24 SET LRFILE3=+$$GET1^DID(LRFILE2,1,"","SPECIFIER")
+25 SET LRIENS3=LRA2_","_LRIENS2
+26 DO WRTSNMD(LRFILE3,LRIENS3,LRCASE,"E",10)
End DoDot:3
End DoDot:2
+27 ;Disease,Function,Procedure
+28 FOR LRDFP="1;3","3;1","4;1.5"
Begin DoDot:2
+29 SET LRDFP(1)=$PIECE(LRDFP,";")
SET LRDFP(2)=$PIECE(LRDFP,";",2)
SET LRA1=0
+30 FOR
SET LRA1=$ORDER(@(LRFIL_"LRA,LRDFP(1),LRA1)"))
if LRA1'>0!(LRQUIT)
QUIT
Begin DoDot:3
+31 SET LRFILE2=+$$GET1^DID(LRFILE1,LRDFP(2),"","SPECIFIER")
+32 SET LRIENS2=LRA1_","_LRIENS1
+33 SET LRPRFX=$SELECT(LRDFP(1)=1:"D",LRDFP(1)=3:"F",1:"P")
+34 DO WRTSNMD(LRFILE2,LRIENS2,LRCASE,LRPRFX,5)
End DoDot:3
End DoDot:2
End DoDot:1
+35 QUIT
CHKSNMD ;Check for SNOMED codes on the accession
+1 NEW LRSB
+2 IF LRAU
Begin DoDot:1
+3 SET LRSB=$QUERY(^LR(LRDFN,"AY",0))
+4 IF $QSUBSCRIPT(LRSB,2)'="AY"
SET LRQUIT=1
End DoDot:1
QUIT
+5 SET LRSB=$QUERY(^LR(LRDFN,LRSS,LRI,2,0))
+6 IF $QSUBSCRIPT(LRSB,4)'=2
SET LRQUIT=1
+7 QUIT
WRTSNMD(LRP1,LRP2,LRP3,LRP4,LRP5) ;
+1 ;LRP1=File number
+2 ;LRP2=IEN string
+3 ;LRP3=Case (Upper or Lower)
+4 ;LRP4=Prefix
+5 ;LRP5=Tab position
+6 NEW LRSM
+7 SET LRSM(1)=$$GET1^DIQ(LRP1,LRP2,.01)
+8 if LRP3
SET LRSM(1)=$$LOW^XLFSTR(LRSM(1))
+9 SET LRSM(2)=LRP4_"-"_$$GET1^DIQ(LRP1,LRP2,".01:2")
+10 SET LRTXT=LRSM(2)_": "_LRSM(1)
+11 IF LRP4="P"
Begin DoDot:1
+12 SET LRSM(3)=$$GET1^DIQ(LRP1,LRP2,.02,"I")
+13 IF LRSM(3)'=""
SET LRTXT=LRTXT_" ("_$SELECT('LRSM(3):"negative",LRSM(3)=1:"positive",1:"?")_")"
End DoDot:1
+14 DO GLENTRY(LRTXT,LRP5,1)
+15 QUIT
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. Othewise, write an current line.
+4 SET LRPR3=+$GET(LRPR3)
+5 if LRPR3
DO NEWLN^LRAPUTL(LRPR1,LRPR2)
+6 if 'LRPR3
DO GLBWRT^LRAPUTL(LRPR1,LRPR2)
+7 QUIT
