Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRAPSNMD

LRAPSNMD.m

Go to the documentation of this file. 
  1. LRAPSNMD ;DALOI/STAFF - Display/print SNOMED codes;Feb 27, 2009
  1.  ;;5.2;LAB SERVICE;**259,350**;Sep 27, 1994;Build 230
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. INIT(LRDFN,LRSS,LRI,LRSF,LRAA,LRAN,LRAD,LRDEM,LRDEV) ;
  1.  ; This routine displays SNOMED codes and their description for the
  1.  ; given record in the LAB DATA (#63) file.
  1.  ;
  1.  ; LRDFN - IEN of the patient's record in the LAB DATA file (#63)
  1.  ;  LRSS - Anatomic Pathology section (i.e. "SP" for Surgical Pathology)
  1.  ;   LRI - Inverse date/time specimen taken
  1.  ;  LRSF - Anatomic Pathology sub-file number (i.e. 63.08 for Surg Path)
  1.  ;  LRAA - IEN of the accession area in the ACCESSION (#68) file
  1.  ;  LRAN - Accession Number
  1.  ;  LRAD - Accession Date
  1.  ; LRDEM - Demographics Array.  The following are used in the header 
  1.  ;         code but are not required:
  1.  ;         LRDEM("PNM") - Patient Name
  1.  ;         LRDEM("PRO") - Provider
  1.  ;         LRDEM("AUDT") - Autopsy Date
  1.  ;         LRDEM("AUTYP") - Autopsy Type
  1.  ;         LRDEM("DTH") - Date of Death
  1.  ;         LRDEM("SSN") - Social Security Number
  1.  ;         LRDEM("SEX") - Sex
  1.  ;         LRDEM("AGE") - Age (or Age at Death for AU)
  1.  ;         LRDEM("DOB") - Date of Birth
  1.  ; LRDEV - 1 indicates use device handling in this routine
  1.  ;         0 indicates use device handling of calling application
  1.  ;
  1.  N LRAU,LRQUIT,LRL
  1.  Q:'$D(LRSS)!('$D(LRDFN))!('$D(LRSF))!('$D(LRAA))!('+$G(LRAN))
  1.  Q:'+$G(LRAD)
  1.  S $P(LRL,"-",79)=""
  1.  S LRAU=$S(LRSS'="AU":0,1:1)
  1.  Q:'LRAU&('$D(LRI))
  1.  ;
  1. MAIN ;
  1.  S LRQUIT=0,LRDEV=+$G(LRDEV)
  1.  D:LRDEV ASKDEV
  1.  I $G(POP)!(LRQUIT) D END Q
  1.  D REPORT
  1.  D END
  1.  Q
  1.  ;
  1.  ;
  1. CHECK ;
  1.  N LRSB
  1.  I LRAU D  Q
  1.  . S LRSB=$Q(^LR(LRDFN,"AY",0))
  1.  . I $QS(LRSB,2)'="AY" D
  1.  . . W !!,"No SNOMED codes found."
  1.  . . S LRQUIT=1
  1.  S LRSB=$Q(^LR(LRDFN,LRSS,LRI,2,0))
  1.  I $QS(LRSB,4)'=2 D
  1.  . W !!,"No SNOMED codes found."
  1.  . S LRQUIT=1
  1.  Q
  1.  ;
  1.  ;
  1. ASKDEV ;
  1.  W !
  1.  S %ZIS="Q" D ^%ZIS
  1.  I POP W ! S LRQUIT=1 Q
  1.  I $D(IO("Q")) D
  1.  . S ZTDESC="LIST OF SNOMED CODES FOR AN ACCESSION"
  1.  . S ZTSAVE("LR*")="",ZTRTN="REPORT^LRAPSNMD"
  1.  . D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued, #",ZTSK W !
  1.  . K ZTSK,IO("Q") D HOME^%ZIS
  1.  . S LRQUIT=1
  1.  Q
  1.  ;
  1.  ;
  1. REPORT ;
  1.  U IO W:IOST["C-" @IOF
  1.  N LRFILE,LRFILE1,LRFILE2,LRFILE3,LRCASE,LRX
  1.  N LRA,LRA1,LRA2,LRIENS,LRIENS1,LRIENS2,LRIENS3
  1.  N LRP1,LRP2,LRP3,LRP4,LRP5,LRDFP,LRPRFX,LRPG,LRPSNM,LRACC,LRSEC
  1.  ;
  1.  S LRIENS=LRAN_","_LRAD_","_LRAA_","
  1.  S LRACC=$$GET1^DIQ(68.02,LRIENS,15,"E")
  1.  S LRSEC=$$GET1^DIQ(68,LRAA_",",.01)
  1.  S (LRQUIT,LRPG)=0
  1.  S LRPSNM=$$GET^XPAR("DIV^PKG","LR AP SNOMED SYSTEM PRINT",1,"Q")
  1.  I LRPSNM<1 S LRPSNM=2
  1.  ;
  1.  D HDR
  1.  ; Print Specimens
  1.  I 'LRAU D  Q:LRQUIT
  1.  . W !,"Tissue Specimen(s): ",!
  1.  . S LRX=0
  1.  . F  S LRX=$O(^LR(LRDFN,LRSS,LRI,.1,LRX)) Q:LRX'>0!(LRQUIT)  D
  1.  . . I $Y>(IOSL-5) D HDR Q:LRQUIT
  1.  . . W ?5,$P($G(^LR(LRDFN,LRSS,LRI,.1,LRX,0)),U),!
  1.  D CHECK
  1.  Q:LRQUIT
  1.  I LRAU D
  1.  . S LRFILE="^LR(LRDFN,""AY"",",LRFILE1=63.2,LRIENS=LRDFN_",",LRCASE=1
  1.  I 'LRAU D
  1.  . S LRFILE="^LR(LRDFN,LRSS,LRI,2,"
  1.  . S LRFILE1=+$$GET1^DID(LRSF,10,"","SPECIFIER")
  1.  . S LRIENS=LRI_","_LRDFN_","
  1.  . S LRCASE=+$$GET1^DIQ(69.2,LRAA_",",.05,"I")
  1.  S LRA=0
  1.  F  S LRA=$O(@(LRFILE_"LRA)")) Q:LRA'>0!(LRQUIT)  D
  1.  . ; Topography
  1.  . S LRIENS1=LRA_","_LRIENS
  1.  . D WRITE(LRFILE1,LRIENS1,LRCASE,"T",0)
  1.  . ; Morphology
  1.  . S LRA1=0
  1.  . F  S LRA1=$O(@(LRFILE_"LRA,2,LRA1)")) Q:LRA1'>0!(LRQUIT)  D
  1.  . . S LRFILE2=+$$GET1^DID(LRFILE1,4,"","SPECIFIER")
  1.  . . S LRIENS2=LRA1_","_LRIENS1
  1.  . . D WRITE(LRFILE2,LRIENS2,LRCASE,"M",5)
  1.  . . ; Etiology
  1.  . . S LRA2=0
  1.  . . F  S LRA2=$O(@(LRFILE_"LRA,2,LRA1,1,LRA2)")) Q:LRA2'>0!(LRQUIT)  D
  1.  . . . S LRFILE3=+$$GET1^DID(LRFILE2,1,"","SPECIFIER")
  1.  . . . S LRIENS3=LRA2_","_LRIENS2
  1.  . . . D WRITE(LRFILE3,LRIENS3,LRCASE,"E",10)
  1.  . ; Disease,Function,Procedure
  1.  . F LRDFP="1;3","3;1","4;1.5" D
  1.  . . S LRDFP(1)=$P(LRDFP,";"),LRDFP(2)=$P(LRDFP,";",2),LRA1=0
  1.  . . F  S LRA1=$O(@(LRFILE_"LRA,LRDFP(1),LRA1)")) Q:LRA1'>0!(LRQUIT)  D
  1.  . . . S LRFILE2=+$$GET1^DID(LRFILE1,LRDFP(2),"","SPECIFIER")
  1.  . . . S LRIENS2=LRA1_","_LRIENS1
  1.  . . . S LRPRFX=$S(LRDFP(1)=1:"D",LRDFP(1)=3:"F",1:"P")
  1.  . . . D WRITE(LRFILE2,LRIENS2,LRCASE,LRPRFX,5)
  1.  Q:LRQUIT
  1.  W !!,$$CJ^XLFSTR("(End of Report)",IOM)
  1.  Q
  1.  ;
  1.  ;
  1. WRITE(LRP1,LRP2,LRP3,LRP4,LRP5) ;
  1.  ; LRP1=File number
  1.  ; LRP2=IEN string
  1.  ; LRP3=Case (Upper or Lower)
  1.  ; LRP4=Prefix
  1.  ; LRP5=Tab position
  1.  N LRSCT,LRSM
  1.  ;
  1.  S LRSM(1)=$$GET1^DIQ(LRP1,LRP2,.01)
  1.  I LRP3 S LRSM(1)=$$LOW^XLFSTR(LRSM(1))
  1.  S LRSM(2)=LRP4_"-"_$$GET1^DIQ(LRP1,LRP2,".01:2")
  1.  ;
  1.  I LRP4?1(1"T",1"E"),LRPSNM?1(1"1",1"3") D WSNM
  1.  I LRP4'="T",LRP4'="E" D WSNM
  1.  ;
  1.  I LRP4?1(1"T",1"E"),LRPSNM>1 D WSCT
  1.  ;
  1.  I $Y>(IOSL-5) D HDR
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. WSNM ; Write SNOMED I codes
  1.  ;
  1.  W !?LRP5,LRSM(2)_": "_LRSM(1)
  1.  I LRP4="P" D
  1.  . S LRSM(3)=$$GET1^DIQ(LRP1,LRP2,.02,"I")
  1.  . I LRSM(3)'="" W " (",$S('LRSM(3):"negative",LRSM(3)=1:"positive",1:"?"),")"
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. WSCT ; Write SCT codes
  1.  ;
  1.  N LRX
  1.  S LRX=$$GET1^DIQ(LRP1,LRP2,.01,"I")
  1.  S LRSCT=$$IEN2SCT^LA7VHLU6($S(LRP4="T":61,LRP4="E":61.2,1:""),LRX,DT,"")
  1.  I LRSCT="" Q
  1.  W !,?LRP5
  1.  I LRPSNM=2 W $S(LRP4="T":"Topography: ",LRP4="E":"Etiology: ",1:"")
  1.  W $P(LRSCT,"^")," (",$P(LRSCT,"^",3),")  ",$P(LRSCT,"^",2)
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. HDR ;
  1.  I LRPG>0,IOST?1"C-".E D  Q:LRQUIT
  1.  . K DIR S DIR(0)="E"
  1.  . D ^DIR W !
  1.  . S:$D(DTOUT)!(X[U) LRQUIT=1
  1.  W:LRPG>0 @IOF S LRPG=LRPG+1
  1.  W !,LRSEC,?24,"SNOMED CODE LISTING",?49,"Acc: ",LRACC
  1.  W:IOST'["BROWSE" ?71,"Pg: ",$J(LRPG,3)
  1.  W !,"Patient: ",$G(LRDEM("PNM"))
  1.  W ?49,$S(LRAU:"Resident: ",1:"Physician: ")
  1.  W $E($G(LRDEM("PRO")),1,18)
  1.  I LRAU D
  1.  . W !,"Autopsy Date: ",$G(LRDEM("AUDT")),?35,$E($G(LRDEM("AUTYP")),1,12)
  1.  . W ?49,"Date Died: ",$G(LRDEM("DTH"))
  1.  W !,"ID: ",$G(LRDEM("SSN"))
  1.  I 'LRAU D
  1.  . W ?24,"Sex: ",$G(LRDEM("SEX")),?49,"DOB: ",$G(LRDEM("DOB"))
  1.  . W ?71,"Age:",$J($G(LRDEM("AGE")),3)
  1.  I LRAU D
  1.  . W ?24,"DOB: ",$G(LRDEM("DOB")),?49,"Age At Death: ",$G(LRDEM("AGE"))
  1.  . W ?72,"Sex: ",$G(LRDEM("SEX"))
  1.  W !,LRL
  1.  Q
  1.  ;
  1.  ;
  1. END ;
  1.  W:IOST?1"P-".E @IOF
  1.  I LRDEV D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
  1.  K %,DIR,DTOUT,DUOUT,DIRUT,X,Y
  1.  Q