source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LR7OB63D.m@ 861

Last change on this file since 861 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.5 KB
Line 
1LR7OB63D ;slc/dcm - Get Autopsy data ;8/11/97
2 ;;5.2;LAB SERVICE;**121,187**;Sep 27, 1994
3AU ;Process AU data
4 N IFN,IFN1,IFN2,X0,X1,X2,X3,X4,X5,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y18,CTR1,PATH,SUB,LRSN
5 Q:'$D(^LR(LRDFN,"AU")) S X0=^("AU"),Y6=$S(+$G(CORRECT):"C",$P(X0,"^",15):"F",$P(X0,"^",3):"R",1:"I"),CTR1=0
6 S:+X0 $P(^TMP("LRX",$J,69,CTR,68),"^",4)=+X0 ;DT of autopsy
7 S:$P(X0,"^",3) $P(^TMP("LRX",$J,69,CTR,68),"^",6)=$P(X0,"^",3) ;DT Completed
8 S PATH=$S($P(X0,"^",10):$P(X0,"^",10),1:$P(X0,"^",7)) ;Pathologist
9 S Y18=";AU;"_IVDT
10 S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,68,CTR1)=$S($D(^TMP("LRX",$J,69,1)):$P(^TMP("LRX",$J,69,1),"^"),1:"")_"^^"_PATH_"^"_$P(X0,"^",3)
11 D WP(33,"SPECIMEN","","ST")
12 S IFN=0
13 F S IFN=$O(^LR(LRDFN,80,IFN)) Q:IFN<1 S X=^(IFN,0),CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)="AUTOPSY ICD9CM CODE^"_$P($G(^ICD9(+X,0)),"^",3)_"^^^^"_Y6_"^^CE^"_$P($G(^ICD9(+X,0)),"^")_"^ICD9^&IMP^^^^AUTOPSY ICD9CM CODE"_"^^^"_Y18
14 D WP(81,"CLINICAL DIAGNOSIS","","TX")
15 D WP(82,"PATHOLOGICAL DIAGNOSIS","","TX")
16 S IFN=0 F S IFN=$O(^LR(LRDFN,84,IFN)) Q:IFN<1 S X=^(IFN,0),IFN1=0 D
17 . F S IFN1=$O(^LR(LRDFN,84,IFN,1,IFN1)) Q:IFN1<1 S X1=^(IFN1,0),CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)="SUPPLEMENTARY REPORT~"_+X_"^"_X1_"^^^^"_Y6_"^^TX^^^^^^^SUPLMNT RPT~"_+X_"^^^"_Y18
18 I $D(^LR(LRDFN,"AV")) S XNODE=^("AV") F IFN=1:1:$L(XNODE,"^") S X1=$P(XNODE,"^",IFN) I $L(X1) S X=$$NODEPIK^LR7OB63(63,"AV",IFN,X1) I $L($P(X,"^")) S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)=X_"^^^^"_Y6_"^^^^^^^^^"_X_"^^^"_Y18
19 I $D(^LR(LRDFN,"AW")) S XNODE=^("AW") F IFN=1:1:$L(XNODE,"^") S X1=$P(XNODE,"^",IFN) I $L(X1) S X=$$NODEPIK^LR7OB63(63,"AW",IFN,X1) I $L($P(X,"^")) S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)=X_"^^^^"_Y6_"^^^^^^^^^"_X_"^^^"_Y18
20 I $D(^LR(LRDFN,"AWI")) S XNODE=^("AWI") F IFN=1:1:$L(XNODE,"^") S X1=$P(XNODE,"^",IFN) I $L(X1) S X=$$NODEPIK^LR7OB63(63,"AWI",IFN,X1) I $L($P(X,"^")) S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)=X_"^^^^"_Y6_"^^^^^^^^^"_X_"^^^"_Y18
21 S IFN=0,SUB=0 F S IFN=$O(^LR(LRDFN,"AY",IFN)) Q:IFN<1 S X=^(IFN,0) D
22 . S SUB=SUB+1,CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)="ORGAN/TISSUE^"_$$POINTER^LR7OB63(63.2,.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(^LAB(61,+X,0)),"^",2)_"^SNM^&ANT^^^^ORG/TISS"_"^^^"_Y18
23 . D PTR(1,"DISEASE",63.21,.01,61.4,"")
24 . S IFN1=0 F S IFN1=$O(^LR(LRDFN,"AY",IFN,2,IFN1)) Q:IFN1<1 S X=^(IFN1,0) D
25 .. S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)="MORPHOLOGY"_"^"_$$POINTER^LR7OB63(63.22,.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(^LAB(61.1,+X,0)),"^",2)_"^SNM^&IMP^^^^MORPH^^^"_Y18
26 .. S IFN2=0 F S IFN2=$O(^LR(LRDFN,"AY",IFN,2,IFN1,1,IFN2)) Q:IFN2<1 S X=^(IFN2,0) D
27 ... S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)="ETIOLOGY^"_$$POINTER^LR7OB63(63.23,.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(^LAB(61.2,+X,0)),"^",2)_"^SNM^^^^^ETIOLOGY^^^"_Y18
28 . D PTR(3,"FUNCTION",63.25,.01,61.3,"")
29 . D PTR(4,"PROCEDURE",63.24,.01,61.5,"&CNP")
30 . S IFN1=0 F S IFN1=$O(^LR(LRDFN,"AY",IFN,5,IFN1)) Q:IFN1<1 S X=^(IFN1,0),IFN2=0 F S IFN2=$O(^LR(LRDFN,"AY",IFN,5,IFN1,1,IFN2)) Q:IFN2<1 S X1=^(IFN2,0) D
31 .. S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,3,CTR1)="SPECIAL STUDIES "_$$SET^LR7OB63(63.26,.01,$P(X,"^"))_"~"_$P(X,"^",2)_"^"_X1_"^^^^^^TX^^^^^^^SPEC STUDIES "_$$SET^LR7OB63(63.26,.01,$P(X,"^"))_"~"_$P(X,"^",2)_"^^^"_Y18
32 Q
33WP(I,NAME,ID,VALTYP) ;Store word processing fields
34 ;I=Node at ^LR(LRDFN,I)
35 ;NAME=Field name
36 ;ID=Coded HL7 ID
37 ;VALTYP="TX" for text, "CE" for coded
38 N IFN,IFN1,X
39 Q:'I Q:'$L(NAME)
40 S IFN=0 F S IFN=$O(^LR(LRDFN,I,IFN)) Q:IFN<1 S X=^(IFN,0) D SPLIT^LR7OU1(X,"^TMP(""LRX"",$J,69,CTR,63)",.CTR1,80,NAME_"^","^^^^"_Y6_"^^"_VALTYP_"^^^"_ID_"^^^^"_NAME_"^^^"_Y18)
41 Q
42PTR(I,NAME,FILE,FIELD,SNMFILE,ID) ;Store ptr fields for ORGAN/TISSUE multiple
43 ;I=Node at ^LR(LRDFN,'AY',IFN,I)
44 ;NAME=Field name
45 ;FILE=File #
46 ;FIELD=Field #
47 ;SNMFILE=Snomed file # for coded entry
48 ;ID=Procedure ID Natl
49 N IFN1
50 Q:'I Q:'$L(NAME)
51 S IFN1=0 F S IFN1=$O(^LR(LRDFN,"AY",IFN,I,IFN1)) Q:IFN1<1 S X=^(IFN1,0) D
52 . S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)=NAME_"^"_$$POINTER^LR7OB63(FILE,FIELD,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(@("^LAB("_SNMFILE_","_+X_",0)")),"^",2)_"^SNM^"_ID_"^^^^"_NAME_"^^^"_Y18
53 Q
54OERR ;Call to OE/RR to setup/update order
55 N X,DR
56 Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S X=$P(^(0),"^",4),LRSN=$P(^(0),"^",5),X=$S($P($G(^LRO(69,+X,1,+LRSN,0)),"^",11):"SC",1:"SN") D ACC^LR7OB1(LRAA,LRAD,LRAN,X)
57 Q
58OE1 ;Get 'before' status of accession
59 N X
60 S CORRECT=0
61 Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LRDFN=+^(0)
62 I LRSS="AU" S:$P($G(^LR(LRDFN,LRSS)),"^",15) CORRECT=1 Q
63 Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) Q:'$P(^(3),"^",5) S X=$P(^(3),"^",5)
64 S:$P($G(^LR(LRDFN,LRSS,X,0)),"^",11) CORRECT=1
65 Q
Note: See TracBrowser for help on using the repository browser.