- LRAPBR2 ;DALOI/WTY/KLL - AP Browser Print ;04/04/01
- ;;5.2;LAB SERVICE;**1030**;NOV 01, 1997
- ;;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
- LRAPBR2 ;DALOI/WTY/KLL - AP Browser Print ;04/04/01
- +1 ;;5.2;LAB SERVICE;**1030**;NOV 01, 1997
- +2 ;;5.2;LAB SERVICE;**259**;Sep 27, 1994
- +3 ;
- +4 ; This routine is a modified version of LRAPT1 to be used for
- +5 ; browser display.
- +6 ;
- +7 NEW LRSS,LRI,LRPATH,LRIENS,LRACN,LRRLDTE,LRRCDTE
- +8 NEW LRTEXT,LRI1,LRI2,LRIENS1,LRSPC
- +9 SET LR("F")=1
- +10 FOR LRSS="SP","CY","EM"
- Begin DoDot:1
- +11 IF '+$PIECE($GET(^LR(LRDFN,LRSS,0)),"^",4)
- QUIT
- +12 SET LRTMP=""
- +13 IF LRSS="SP"
- SET LRTMP="SURGICAL PATHOLOGY"
- SET (LRFILE,LRXF)=63.08
- +14 IF LRSS="CY"
- SET LRTMP="CYTOPATHOLOGY"
- SET (LRFILE,LRXF)=63.09
- +15 IF LRSS="EM"
- SET LRTMP="ELECTRON MICROSCOPY"
- SET (LRFILE,LRXF)=63.02
- +16 DO GLENTRY("","",1)
- DO GLENTRY(LRTMP,30,1)
- +17 KILL LRTMP
- +18 SET LRI=0
- FOR
- SET LRI=$ORDER(^LR(LRDFN,LRSS,LRI))
- IF 'LRI
- QUIT
- Begin DoDot:2
- +19 SET LRIENS=LRI_","_LRDFN_","
- +20 SET LRPATH=$EXTRACT($$GET1^DIQ(LRFILE,LRIENS,.02,""),1,12)
- +21 SET LRACN=$$GET1^DIQ(LRFILE,LRIENS,.06,"")
- +22 IF LRACN=""
- SET LRACN="?"
- +23 SET LRRLDTE=$$GET1^DIQ(LRFILE,LRIENS,.11,"")
- +24 SET LRRCDTE=$$FMTE^XLFDT($$GET1^DIQ(LRFILE,LRIENS,.1,"I"),"D")
- +25 DO GLENTRY("Organ/tissue:",2,1)
- +26 DO GLENTRY("Date rec'd: "_LRRCDTE,17)
- +27 DO GLENTRY("Acc #:"_LRACN,43)
- +28 DO GLENTRY(LRPATH,64)
- +29 IF LRRLDTE=""
- DO GLENTRY("Report not verified.",5,1)
- +30 ;KLL - Display Snomed Codes on report in Browser
- +31 DO GETSNMD
- +32 IF LRRLDTE=""
- QUIT
- +33 ;Special Studies
- +34 SET LRFILE1=+$$GET1^DID(LRFILE,10,"","SPECIFIER")
- +35 SET LRI1=0
- FOR
- SET LRI1=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRI1))
- IF 'LRI1
- QUIT
- Begin DoDot:3
- +36 SET LRFILE2=+$$GET1^DID(LRFILE1,5,"","SPECIFIER")
- +37 SET LRI2=0
- FOR
- SET LRI2=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRI1,5,LRI2))
- IF 'LRI2
- QUIT
- Begin DoDot:4
- +38 SET LRIENS1=LRI2_","_LRI1_","_LRIENS
- +39 DO GETS^DIQ(LRFILE2,LRIENS1,".01;.03","","LRARR")
- +40 MERGE LRSPC=LRARR(LRFILE2,LRIENS1)
- +41 SET LRSPC(.02)=$$GET1^DIQ(LRFILE2,LRIENS1,.02,"E")
- +42 SET LRTEXT=LRSPC(.01)_" "_LRSPC(.03)_" Date: "_LRSPC(.02)
- +43 DO GLENTRY(LRTEXT,5,1)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +44 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
