LRAPSNMD ;DALOI/STAFF - Display/print SNOMED codes;Feb 27, 2009
;;5.2;LAB SERVICE;**259,350**;Sep 27, 1994;Build 230
;
Q
;
;
INIT(LRDFN,LRSS,LRI,LRSF,LRAA,LRAN,LRAD,LRDEM,LRDEV) ;
; This routine displays SNOMED codes and their description for the
; given record in the LAB DATA (#63) file.
;
; LRDFN - IEN of the patient's record in the LAB DATA file (#63)
; LRSS - Anatomic Pathology section (i.e. "SP" for Surgical Pathology)
; LRI - Inverse date/time specimen taken
; LRSF - Anatomic Pathology sub-file number (i.e. 63.08 for Surg Path)
; LRAA - IEN of the accession area in the ACCESSION (#68) file
; LRAN - Accession Number
; LRAD - Accession Date
; LRDEM - Demographics Array. The following are used in the header
; code but are not required:
; LRDEM("PNM") - Patient Name
; LRDEM("PRO") - Provider
; LRDEM("AUDT") - Autopsy Date
; LRDEM("AUTYP") - Autopsy Type
; LRDEM("DTH") - Date of Death
; LRDEM("SSN") - Social Security Number
; LRDEM("SEX") - Sex
; LRDEM("AGE") - Age (or Age at Death for AU)
; LRDEM("DOB") - Date of Birth
; LRDEV - 1 indicates use device handling in this routine
; 0 indicates use device handling of calling application
;
N LRAU,LRQUIT,LRL
Q:'$D(LRSS)!('$D(LRDFN))!('$D(LRSF))!('$D(LRAA))!('+$G(LRAN))
Q:'+$G(LRAD)
S $P(LRL,"-",79)=""
S LRAU=$S(LRSS'="AU":0,1:1)
Q:'LRAU&('$D(LRI))
;
MAIN ;
S LRQUIT=0,LRDEV=+$G(LRDEV)
D:LRDEV ASKDEV
I $G(POP)!(LRQUIT) D END Q
D REPORT
D END
Q
;
;
CHECK ;
N LRSB
I LRAU D Q
. S LRSB=$Q(^LR(LRDFN,"AY",0))
. I $QS(LRSB,2)'="AY" D
. . W !!,"No SNOMED codes found."
. . S LRQUIT=1
S LRSB=$Q(^LR(LRDFN,LRSS,LRI,2,0))
I $QS(LRSB,4)'=2 D
. W !!,"No SNOMED codes found."
. S LRQUIT=1
Q
;
;
ASKDEV ;
W !
S %ZIS="Q" D ^%ZIS
I POP W ! S LRQUIT=1 Q
I $D(IO("Q")) D
. S ZTDESC="LIST OF SNOMED CODES FOR AN ACCESSION"
. S ZTSAVE("LR*")="",ZTRTN="REPORT^LRAPSNMD"
. D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !
. K ZTSK,IO("Q") D HOME^%ZIS
. S LRQUIT=1
Q
;
;
REPORT ;
U IO W:IOST["C-" @IOF
N LRFILE,LRFILE1,LRFILE2,LRFILE3,LRCASE,LRX
N LRA,LRA1,LRA2,LRIENS,LRIENS1,LRIENS2,LRIENS3
N LRP1,LRP2,LRP3,LRP4,LRP5,LRDFP,LRPRFX,LRPG,LRPSNM,LRACC,LRSEC
;
S LRIENS=LRAN_","_LRAD_","_LRAA_","
S LRACC=$$GET1^DIQ(68.02,LRIENS,15,"E")
S LRSEC=$$GET1^DIQ(68,LRAA_",",.01)
S (LRQUIT,LRPG)=0
S LRPSNM=$$GET^XPAR("DIV^PKG","LR AP SNOMED SYSTEM PRINT",1,"Q")
I LRPSNM<1 S LRPSNM=2
;
D HDR
; Print Specimens
I 'LRAU D Q:LRQUIT
. W !,"Tissue Specimen(s): ",!
. S LRX=0
. F S LRX=$O(^LR(LRDFN,LRSS,LRI,.1,LRX)) Q:LRX'>0!(LRQUIT) D
. . I $Y>(IOSL-5) D HDR Q:LRQUIT
. . W ?5,$P($G(^LR(LRDFN,LRSS,LRI,.1,LRX,0)),U),!
D CHECK
Q:LRQUIT
I LRAU D
. S LRFILE="^LR(LRDFN,""AY"",",LRFILE1=63.2,LRIENS=LRDFN_",",LRCASE=1
I 'LRAU D
. S LRFILE="^LR(LRDFN,LRSS,LRI,2,"
. S LRFILE1=+$$GET1^DID(LRSF,10,"","SPECIFIER")
. S LRIENS=LRI_","_LRDFN_","
. S LRCASE=+$$GET1^DIQ(69.2,LRAA_",",.05,"I")
S LRA=0
F S LRA=$O(@(LRFILE_"LRA)")) Q:LRA'>0!(LRQUIT) D
. ; Topography
. S LRIENS1=LRA_","_LRIENS
. D WRITE(LRFILE1,LRIENS1,LRCASE,"T",0)
. ; Morphology
. S LRA1=0
. F S LRA1=$O(@(LRFILE_"LRA,2,LRA1)")) Q:LRA1'>0!(LRQUIT) D
. . S LRFILE2=+$$GET1^DID(LRFILE1,4,"","SPECIFIER")
. . S LRIENS2=LRA1_","_LRIENS1
. . D WRITE(LRFILE2,LRIENS2,LRCASE,"M",5)
. . ; Etiology
. . S LRA2=0
. . F S LRA2=$O(@(LRFILE_"LRA,2,LRA1,1,LRA2)")) Q:LRA2'>0!(LRQUIT) D
. . . S LRFILE3=+$$GET1^DID(LRFILE2,1,"","SPECIFIER")
. . . S LRIENS3=LRA2_","_LRIENS2
. . . D WRITE(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(@(LRFILE_"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 WRITE(LRFILE2,LRIENS2,LRCASE,LRPRFX,5)
Q:LRQUIT
W !!,$$CJ^XLFSTR("(End of Report)",IOM)
Q
;
;
WRITE(LRP1,LRP2,LRP3,LRP4,LRP5) ;
; LRP1=File number
; LRP2=IEN string
; LRP3=Case (Upper or Lower)
; LRP4=Prefix
; LRP5=Tab position
N LRSCT,LRSM
;
S LRSM(1)=$$GET1^DIQ(LRP1,LRP2,.01)
I LRP3 S LRSM(1)=$$LOW^XLFSTR(LRSM(1))
S LRSM(2)=LRP4_"-"_$$GET1^DIQ(LRP1,LRP2,".01:2")
;
I LRP4?1(1"T",1"E"),LRPSNM?1(1"1",1"3") D WSNM
I LRP4'="T",LRP4'="E" D WSNM
;
I LRP4?1(1"T",1"E"),LRPSNM>1 D WSCT
;
I $Y>(IOSL-5) D HDR
;
Q
;
;
WSNM ; Write SNOMED I codes
;
W !?LRP5,LRSM(2)_": "_LRSM(1)
I LRP4="P" D
. S LRSM(3)=$$GET1^DIQ(LRP1,LRP2,.02,"I")
. I LRSM(3)'="" W " (",$S('LRSM(3):"negative",LRSM(3)=1:"positive",1:"?"),")"
;
Q
;
;
WSCT ; Write SCT codes
;
N LRX
S LRX=$$GET1^DIQ(LRP1,LRP2,.01,"I")
S LRSCT=$$IEN2SCT^LA7VHLU6($S(LRP4="T":61,LRP4="E":61.2,1:""),LRX,DT,"")
I LRSCT="" Q
W !,?LRP5
I LRPSNM=2 W $S(LRP4="T":"Topography: ",LRP4="E":"Etiology: ",1:"")
W $P(LRSCT,"^")," (",$P(LRSCT,"^",3),") ",$P(LRSCT,"^",2)
;
Q
;
;
HDR ;
I LRPG>0,IOST?1"C-".E D Q:LRQUIT
. K DIR S DIR(0)="E"
. D ^DIR W !
. S:$D(DTOUT)!(X[U) LRQUIT=1
W:LRPG>0 @IOF S LRPG=LRPG+1
W !,LRSEC,?24,"SNOMED CODE LISTING",?49,"Acc: ",LRACC
W:IOST'["BROWSE" ?71,"Pg: ",$J(LRPG,3)
W !,"Patient: ",$G(LRDEM("PNM"))
W ?49,$S(LRAU:"Resident: ",1:"Physician: ")
W $E($G(LRDEM("PRO")),1,18)
I LRAU D
. W !,"Autopsy Date: ",$G(LRDEM("AUDT")),?35,$E($G(LRDEM("AUTYP")),1,12)
. W ?49,"Date Died: ",$G(LRDEM("DTH"))
W !,"ID: ",$G(LRDEM("SSN"))
I 'LRAU D
. W ?24,"Sex: ",$G(LRDEM("SEX")),?49,"DOB: ",$G(LRDEM("DOB"))
. W ?71,"Age:",$J($G(LRDEM("AGE")),3)
I LRAU D
. W ?24,"DOB: ",$G(LRDEM("DOB")),?49,"Age At Death: ",$G(LRDEM("AGE"))
. W ?72,"Sex: ",$G(LRDEM("SEX"))
W !,LRL
Q
;
;
END ;
W:IOST?1"P-".E @IOF
I LRDEV D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
K %,DIR,DTOUT,DUOUT,DIRUT,X,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPSNMD 6090 printed Apr 09, 2024@21:18:07 Page 2
LRAPSNMD ;DALOI/STAFF - Display/print SNOMED codes;Feb 27, 2009
+1 ;;5.2;LAB SERVICE;**259,350**;Sep 27, 1994;Build 230
+2 ;
+3 QUIT
+4 ;
+5 ;
INIT(LRDFN,LRSS,LRI,LRSF,LRAA,LRAN,LRAD,LRDEM,LRDEV) ;
+1 ; This routine displays SNOMED codes and their description for the
+2 ; given record in the LAB DATA (#63) file.
+3 ;
+4 ; LRDFN - IEN of the patient's record in the LAB DATA file (#63)
+5 ; LRSS - Anatomic Pathology section (i.e. "SP" for Surgical Pathology)
+6 ; LRI - Inverse date/time specimen taken
+7 ; LRSF - Anatomic Pathology sub-file number (i.e. 63.08 for Surg Path)
+8 ; LRAA - IEN of the accession area in the ACCESSION (#68) file
+9 ; LRAN - Accession Number
+10 ; LRAD - Accession Date
+11 ; LRDEM - Demographics Array. The following are used in the header
+12 ; code but are not required:
+13 ; LRDEM("PNM") - Patient Name
+14 ; LRDEM("PRO") - Provider
+15 ; LRDEM("AUDT") - Autopsy Date
+16 ; LRDEM("AUTYP") - Autopsy Type
+17 ; LRDEM("DTH") - Date of Death
+18 ; LRDEM("SSN") - Social Security Number
+19 ; LRDEM("SEX") - Sex
+20 ; LRDEM("AGE") - Age (or Age at Death for AU)
+21 ; LRDEM("DOB") - Date of Birth
+22 ; LRDEV - 1 indicates use device handling in this routine
+23 ; 0 indicates use device handling of calling application
+24 ;
+25 NEW LRAU,LRQUIT,LRL
+26 if '$DATA(LRSS)!('$DATA(LRDFN))!('$DATA(LRSF))!('$DATA(LRAA))!('+$GET(LRAN))
QUIT
+27 if '+$GET(LRAD)
QUIT
+28 SET $PIECE(LRL,"-",79)=""
+29 SET LRAU=$SELECT(LRSS'="AU":0,1:1)
+30 if 'LRAU&('$DATA(LRI))
QUIT
+31 ;
MAIN ;
+1 SET LRQUIT=0
SET LRDEV=+$GET(LRDEV)
+2 if LRDEV
DO ASKDEV
+3 IF $GET(POP)!(LRQUIT)
DO END
QUIT
+4 DO REPORT
+5 DO END
+6 QUIT
+7 ;
+8 ;
CHECK ;
+1 NEW LRSB
+2 IF LRAU
Begin DoDot:1
+3 SET LRSB=$QUERY(^LR(LRDFN,"AY",0))
+4 IF $QSUBSCRIPT(LRSB,2)'="AY"
Begin DoDot:2
+5 WRITE !!,"No SNOMED codes found."
+6 SET LRQUIT=1
End DoDot:2
End DoDot:1
QUIT
+7 SET LRSB=$QUERY(^LR(LRDFN,LRSS,LRI,2,0))
+8 IF $QSUBSCRIPT(LRSB,4)'=2
Begin DoDot:1
+9 WRITE !!,"No SNOMED codes found."
+10 SET LRQUIT=1
End DoDot:1
+11 QUIT
+12 ;
+13 ;
ASKDEV ;
+1 WRITE !
+2 SET %ZIS="Q"
DO ^%ZIS
+3 IF POP
WRITE !
SET LRQUIT=1
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTDESC="LIST OF SNOMED CODES FOR AN ACCESSION"
+6 SET ZTSAVE("LR*")=""
SET ZTRTN="REPORT^LRAPSNMD"
+7 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Request Queued, #",ZTSK
WRITE !
+8 KILL ZTSK,IO("Q")
DO HOME^%ZIS
+9 SET LRQUIT=1
End DoDot:1
+10 QUIT
+11 ;
+12 ;
REPORT ;
+1 USE IO
if IOST["C-"
WRITE @IOF
+2 NEW LRFILE,LRFILE1,LRFILE2,LRFILE3,LRCASE,LRX
+3 NEW LRA,LRA1,LRA2,LRIENS,LRIENS1,LRIENS2,LRIENS3
+4 NEW LRP1,LRP2,LRP3,LRP4,LRP5,LRDFP,LRPRFX,LRPG,LRPSNM,LRACC,LRSEC
+5 ;
+6 SET LRIENS=LRAN_","_LRAD_","_LRAA_","
+7 SET LRACC=$$GET1^DIQ(68.02,LRIENS,15,"E")
+8 SET LRSEC=$$GET1^DIQ(68,LRAA_",",.01)
+9 SET (LRQUIT,LRPG)=0
+10 SET LRPSNM=$$GET^XPAR("DIV^PKG","LR AP SNOMED SYSTEM PRINT",1,"Q")
+11 IF LRPSNM<1
SET LRPSNM=2
+12 ;
+13 DO HDR
+14 ; Print Specimens
+15 IF 'LRAU
Begin DoDot:1
+16 WRITE !,"Tissue Specimen(s): ",!
+17 SET LRX=0
+18 FOR
SET LRX=$ORDER(^LR(LRDFN,LRSS,LRI,.1,LRX))
if LRX'>0!(LRQUIT)
QUIT
Begin DoDot:2
+19 IF $Y>(IOSL-5)
DO HDR
if LRQUIT
QUIT
+20 WRITE ?5,$PIECE($GET(^LR(LRDFN,LRSS,LRI,.1,LRX,0)),U),!
End DoDot:2
End DoDot:1
if LRQUIT
QUIT
+21 DO CHECK
+22 if LRQUIT
QUIT
+23 IF LRAU
Begin DoDot:1
+24 SET LRFILE="^LR(LRDFN,""AY"","
SET LRFILE1=63.2
SET LRIENS=LRDFN_","
SET LRCASE=1
End DoDot:1
+25 IF 'LRAU
Begin DoDot:1
+26 SET LRFILE="^LR(LRDFN,LRSS,LRI,2,"
+27 SET LRFILE1=+$$GET1^DID(LRSF,10,"","SPECIFIER")
+28 SET LRIENS=LRI_","_LRDFN_","
+29 SET LRCASE=+$$GET1^DIQ(69.2,LRAA_",",.05,"I")
End DoDot:1
+30 SET LRA=0
+31 FOR
SET LRA=$ORDER(@(LRFILE_"LRA)"))
if LRA'>0!(LRQUIT)
QUIT
Begin DoDot:1
+32 ; Topography
+33 SET LRIENS1=LRA_","_LRIENS
+34 DO WRITE(LRFILE1,LRIENS1,LRCASE,"T",0)
+35 ; Morphology
+36 SET LRA1=0
+37 FOR
SET LRA1=$ORDER(@(LRFILE_"LRA,2,LRA1)"))
if LRA1'>0!(LRQUIT)
QUIT
Begin DoDot:2
+38 SET LRFILE2=+$$GET1^DID(LRFILE1,4,"","SPECIFIER")
+39 SET LRIENS2=LRA1_","_LRIENS1
+40 DO WRITE(LRFILE2,LRIENS2,LRCASE,"M",5)
+41 ; Etiology
+42 SET LRA2=0
+43 FOR
SET LRA2=$ORDER(@(LRFILE_"LRA,2,LRA1,1,LRA2)"))
if LRA2'>0!(LRQUIT)
QUIT
Begin DoDot:3
+44 SET LRFILE3=+$$GET1^DID(LRFILE2,1,"","SPECIFIER")
+45 SET LRIENS3=LRA2_","_LRIENS2
+46 DO WRITE(LRFILE3,LRIENS3,LRCASE,"E",10)
End DoDot:3
End DoDot:2
+47 ; Disease,Function,Procedure
+48 FOR LRDFP="1;3","3;1","4;1.5"
Begin DoDot:2
+49 SET LRDFP(1)=$PIECE(LRDFP,";")
SET LRDFP(2)=$PIECE(LRDFP,";",2)
SET LRA1=0
+50 FOR
SET LRA1=$ORDER(@(LRFILE_"LRA,LRDFP(1),LRA1)"))
if LRA1'>0!(LRQUIT)
QUIT
Begin DoDot:3
+51 SET LRFILE2=+$$GET1^DID(LRFILE1,LRDFP(2),"","SPECIFIER")
+52 SET LRIENS2=LRA1_","_LRIENS1
+53 SET LRPRFX=$SELECT(LRDFP(1)=1:"D",LRDFP(1)=3:"F",1:"P")
+54 DO WRITE(LRFILE2,LRIENS2,LRCASE,LRPRFX,5)
End DoDot:3
End DoDot:2
End DoDot:1
+55 if LRQUIT
QUIT
+56 WRITE !!,$$CJ^XLFSTR("(End of Report)",IOM)
+57 QUIT
+58 ;
+59 ;
WRITE(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 LRSCT,LRSM
+7 ;
+8 SET LRSM(1)=$$GET1^DIQ(LRP1,LRP2,.01)
+9 IF LRP3
SET LRSM(1)=$$LOW^XLFSTR(LRSM(1))
+10 SET LRSM(2)=LRP4_"-"_$$GET1^DIQ(LRP1,LRP2,".01:2")
+11 ;
+12 IF LRP4?1(1"T",1"E")
IF LRPSNM?1(1"1",1"3")
DO WSNM
+13 IF LRP4'="T"
IF LRP4'="E"
DO WSNM
+14 ;
+15 IF LRP4?1(1"T",1"E")
IF LRPSNM>1
DO WSCT
+16 ;
+17 IF $Y>(IOSL-5)
DO HDR
+18 ;
+19 QUIT
+20 ;
+21 ;
WSNM ; Write SNOMED I codes
+1 ;
+2 WRITE !?LRP5,LRSM(2)_": "_LRSM(1)
+3 IF LRP4="P"
Begin DoDot:1
+4 SET LRSM(3)=$$GET1^DIQ(LRP1,LRP2,.02,"I")
+5 IF LRSM(3)'=""
WRITE " (",$SELECT('LRSM(3):"negative",LRSM(3)=1:"positive",1:"?"),")"
End DoDot:1
+6 ;
+7 QUIT
+8 ;
+9 ;
WSCT ; Write SCT codes
+1 ;
+2 NEW LRX
+3 SET LRX=$$GET1^DIQ(LRP1,LRP2,.01,"I")
+4 SET LRSCT=$$IEN2SCT^LA7VHLU6($SELECT(LRP4="T":61,LRP4="E":61.2,1:""),LRX,DT,"")
+5 IF LRSCT=""
QUIT
+6 WRITE !,?LRP5
+7 IF LRPSNM=2
WRITE $SELECT(LRP4="T":"Topography: ",LRP4="E":"Etiology: ",1:"")
+8 WRITE $PIECE(LRSCT,"^")," (",$PIECE(LRSCT,"^",3),") ",$PIECE(LRSCT,"^",2)
+9 ;
+10 QUIT
+11 ;
+12 ;
HDR ;
+1 IF LRPG>0
IF IOST?1"C-".E
Begin DoDot:1
+2 KILL DIR
SET DIR(0)="E"
+3 DO ^DIR
WRITE !
+4 if $DATA(DTOUT)!(X[U)
SET LRQUIT=1
End DoDot:1
if LRQUIT
QUIT
+5 if LRPG>0
WRITE @IOF
SET LRPG=LRPG+1
+6 WRITE !,LRSEC,?24,"SNOMED CODE LISTING",?49,"Acc: ",LRACC
+7 if IOST'["BROWSE"
WRITE ?71,"Pg: ",$JUSTIFY(LRPG,3)
+8 WRITE !,"Patient: ",$GET(LRDEM("PNM"))
+9 WRITE ?49,$SELECT(LRAU:"Resident: ",1:"Physician: ")
+10 WRITE $EXTRACT($GET(LRDEM("PRO")),1,18)
+11 IF LRAU
Begin DoDot:1
+12 WRITE !,"Autopsy Date: ",$GET(LRDEM("AUDT")),?35,$EXTRACT($GET(LRDEM("AUTYP")),1,12)
+13 WRITE ?49,"Date Died: ",$GET(LRDEM("DTH"))
End DoDot:1
+14 WRITE !,"ID: ",$GET(LRDEM("SSN"))
+15 IF 'LRAU
Begin DoDot:1
+16 WRITE ?24,"Sex: ",$GET(LRDEM("SEX")),?49,"DOB: ",$GET(LRDEM("DOB"))
+17 WRITE ?71,"Age:",$JUSTIFY($GET(LRDEM("AGE")),3)
End DoDot:1
+18 IF LRAU
Begin DoDot:1
+19 WRITE ?24,"DOB: ",$GET(LRDEM("DOB")),?49,"Age At Death: ",$GET(LRDEM("AGE"))
+20 WRITE ?72,"Sex: ",$GET(LRDEM("SEX"))
End DoDot:1
+21 WRITE !,LRL
+22 QUIT
+23 ;
+24 ;
END ;
+1 if IOST?1"P-".E
WRITE @IOF
+2 IF LRDEV
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 KILL %,DIR,DTOUT,DUOUT,DIRUT,X,Y
+4 QUIT
