LR7OB63D ;VA/slc/dcm - Get Autopsy data ; 17-Oct-2014 09:22 ; MKK
;;5.2;LAB SERVICE;**1003,121,187,315,1031,1034**;NOV 01, 1997;Build 188
;
AU ;Process AU data
N IFN,IFN1,IFN2,X0,X1,X2,X3,X4,X5,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y18,CTR1,PATH,SUB,LRSN
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
S:+X0 $P(^TMP("LRX",$J,69,CTR,68),"^",4)=+X0 ;DT of autopsy
S:$P(X0,"^",3) $P(^TMP("LRX",$J,69,CTR,68),"^",6)=$P(X0,"^",3) ;DT Completed
S PATH=$S($P(X0,"^",10):$P(X0,"^",10),1:$P(X0,"^",7)) ;Pathologist
S Y18=";AU;"_IVDT
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)
D WP(33,"SPECIMEN","","ST")
S IFN=0 F S IFN=$O(^LR(LRDFN,80,IFN)) Q:IFN<1 D
. N LRX,LRTMP
. ; S LRX=^(IFN,0),LRX=$$ICDDX^ICDCODE(+LRX,,,1)
. S LRX=^(IFN,0),LRX=$$ICDDX^ICDEX(+LRX,,,"I") ; IHS/MSC/MKK - LR*5.2*1034
. S CTR1=CTR1+1,LRTMP="AUTOPSY ICD9CM CODE^"
. S LRTMP=LRTMP_$P(LRX,"^",4)_"^^^^"_Y6_"^^CE^"_$P(LRX,"^",2)
. S LRTMP=LRTMP_"^ICD9^&IMP^^^^AUTOPSY ICD9CM CODE"_"^^^"_Y18
. S ^TMP("LRX",$J,69,CTR,63,CTR1)=LRTMP
. Q
D WP(81,"CLINICAL DIAGNOSIS","","TX")
D WP(82,"PATHOLOGICAL DIAGNOSIS","","TX")
S IFN=0 F S IFN=$O(^LR(LRDFN,84,IFN)) Q:IFN<1 S X=^(IFN,0),IFN1=0 D
. 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
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
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
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
S IFN=0,SUB=0 F S IFN=$O(^LR(LRDFN,"AY",IFN)) Q:IFN<1 S X=^(IFN,0) D
. 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
. D PTR(1,"DISEASE",63.21,.01,61.4,"")
. S IFN1=0 F S IFN1=$O(^LR(LRDFN,"AY",IFN,2,IFN1)) Q:IFN1<1 S X=^(IFN1,0) D
.. 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
.. S IFN2=0 F S IFN2=$O(^LR(LRDFN,"AY",IFN,2,IFN1,1,IFN2)) Q:IFN2<1 S X=^(IFN2,0) D
... 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
. D PTR(3,"FUNCTION",63.25,.01,61.3,"")
. D PTR(4,"PROCEDURE",63.24,.01,61.5,"&CNP")
. 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
.. 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
Q
WP(I,NAME,ID,VALTYP) ;Store word processing fields
;I=Node at ^LR(LRDFN,I)
;NAME=Field name
;ID=Coded HL7 ID
;VALTYP="TX" for text, "CE" for coded
N IFN,IFN1,X
Q:'I Q:'$L(NAME)
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)
Q
PTR(I,NAME,FILE,FIELD,SNMFILE,ID) ;Store ptr fields for ORGAN/TISSUE multiple
;I=Node at ^LR(LRDFN,'AY',IFN,I)
;NAME=Field name
;FILE=File #
;FIELD=Field #
;SNMFILE=Snomed file # for coded entry
;ID=Procedure ID Natl
N IFN1
Q:'I Q:'$L(NAME)
S IFN1=0 F S IFN1=$O(^LR(LRDFN,"AY",IFN,I,IFN1)) Q:IFN1<1 S X=^(IFN1,0) D
. 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
Q
OERR ;Call to OE/RR to setup/update order
N X,DR
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)
Q
OE1 ;Get 'before' status of accession
N X
S CORRECT=0
Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) S LRDFN=+^(0)
I LRSS="AU" S:$P($G(^LR(LRDFN,LRSS)),"^",15) CORRECT=1 Q
Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) Q:'$P(^(3),"^",5) S X=$P(^(3),"^",5)
S:$P($G(^LR(LRDFN,LRSS,X,0)),"^",11) CORRECT=1
Q
LR7OB63D ;VA/slc/dcm - Get Autopsy data ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**1003,121,187,315,1031,1034**;NOV 01, 1997;Build 188
+2 ;
AU ;Process AU data
+1 NEW IFN,IFN1,IFN2,X0,X1,X2,X3,X4,X5,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y18,CTR1,PATH,SUB,LRSN
+2 IF '$DATA(^LR(LRDFN,"AU"))
QUIT
SET X0=^("AU")
SET Y6=$SELECT(+$GET(CORRECT):"C",$PIECE(X0,"^",15):"F",$PIECE(X0,"^",3):"R",1:"I")
SET CTR1=0
+3 ;DT of autopsy
IF +X0
SET $PIECE(^TMP("LRX",$JOB,69,CTR,68),"^",4)=+X0
+4 ;DT Completed
IF $PIECE(X0,"^",3)
SET $PIECE(^TMP("LRX",$JOB,69,CTR,68),"^",6)=$PIECE(X0,"^",3)
+5 ;Pathologist
SET PATH=$SELECT($PIECE(X0,"^",10):$PIECE(X0,"^",10),1:$PIECE(X0,"^",7))
+6 SET Y18=";AU;"_IVDT
+7 SET CTR1=CTR1+1
SET ^TMP("LRX",$JOB,69,CTR,68,CTR1)=$SELECT($DATA(^TMP("LRX",$JOB,69,1)):$PIECE(^TMP("LRX",$JOB,69,1),"^"),1:"")_"^^"_PATH_"^"_$PIECE(X0,"^",3)
+8 DO WP(33,"SPECIMEN","","ST")
+9 SET IFN=0
FOR
SET IFN=$ORDER(^LR(LRDFN,80,IFN))
IF IFN<1
QUIT
Begin DoDot:1
+10 NEW LRX,LRTMP
+11 ; S LRX=^(IFN,0),LRX=$$ICDDX^ICDCODE(+LRX,,,1)
+12 ; IHS/MSC/MKK - LR*5.2*1034
SET LRX=^(IFN,0)
SET LRX=$$ICDDX^ICDEX(+LRX,,,"I")
+13 SET CTR1=CTR1+1
SET LRTMP="AUTOPSY ICD9CM CODE^"
+14 SET LRTMP=LRTMP_$PIECE(LRX,"^",4)_"^^^^"_Y6_"^^CE^"_$PIECE(LRX,"^",2)
+15 SET LRTMP=LRTMP_"^ICD9^&IMP^^^^AUTOPSY ICD9CM CODE"_"^^^"_Y18
+16 SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)=LRTMP
+17 QUIT
End DoDot:1
+18 DO WP(81,"CLINICAL DIAGNOSIS","","TX")
+19 DO WP(82,"PATHOLOGICAL DIAGNOSIS","","TX")
+20 SET IFN=0
FOR
SET IFN=$ORDER(^LR(LRDFN,84,IFN))
IF IFN<1
QUIT
SET X=^(IFN,0)
SET IFN1=0
Begin DoDot:1
+21 FOR
SET IFN1=$ORDER(^LR(LRDFN,84,IFN,1,IFN1))
IF IFN1<1
QUIT
SET X1=^(IFN1,0)
SET CTR1=CTR1+1
SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)="SUPPLEMENTARY REPORT~"_+X_"^"_X1_"^^^^"_Y6_"^^TX^^^^^^^SUPLMNT RPT~"_+X_"^^^"_Y18
End DoDot:1
+22 IF $DATA(^LR(LRDFN,"AV"))
SET XNODE=^("AV")
FOR IFN=1:1:$LENGTH(XNODE,"^")
SET X1=$PIECE(XNODE,"^",IFN)
IF $LENGTH(X1)
SET X=$$NODEPIK^LR7OB63(63,"AV",IFN,X1)
IF $LENGTH($PIECE(X,"^"))
SET CTR1=CTR1+1
SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)=X_"^^^^"_Y6_"^^^^^^^^^"_X_"^^^"_Y18
+23 IF $DATA(^LR(LRDFN,"AW"))
SET XNODE=^("AW")
FOR IFN=1:1:$LENGTH(XNODE,"^")
SET X1=$PIECE(XNODE,"^",IFN)
IF $LENGTH(X1)
SET X=$$NODEPIK^LR7OB63(63,"AW",IFN,X1)
IF $LENGTH($PIECE(X,"^"))
SET CTR1=CTR1+1
SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)=X_"^^^^"_Y6_"^^^^^^^^^"_X_"^^^"_Y18
+24 IF $DATA(^LR(LRDFN,"AWI"))
SET XNODE=^("AWI")
FOR IFN=1:1:$LENGTH(XNODE,"^")
SET X1=$PIECE(XNODE,"^",IFN)
IF $LENGTH(X1)
SET X=$$NODEPIK^LR7OB63(63,"AWI",IFN,X1)
IF $LENGTH($PIECE(X,"^"))
SET CTR1=CTR1+1
SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)=X_"^^^^"_Y6_"^^^^^^^^^"_X_"^^^"_Y18
+25 SET IFN=0
SET SUB=0
FOR
SET IFN=$ORDER(^LR(LRDFN,"AY",IFN))
IF IFN<1
QUIT
SET X=^(IFN,0)
Begin DoDot:1
+26 SET SUB=SUB+1
SET CTR1=CTR1+1
SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)="ORGAN/TISSUE^"_$$POINTER^LR7OB63(63.2,.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$PIECE($GET(^LAB(61,+X,0)),"^",2)_"^SNM^&ANT^^^^ORG/TISS"_"^^^"_Y18
+27 DO PTR(1,"DISEASE",63.21,.01,61.4,"")
+28 SET IFN1=0
FOR
SET IFN1=$ORDER(^LR(LRDFN,"AY",IFN,2,IFN1))
IF IFN1<1
QUIT
SET X=^(IFN1,0)
Begin DoDot:2
+29 SET CTR1=CTR1+1
SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)="MORPHOLOGY"_"^"_$$POINTER^LR7OB63(63.22,.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$PIECE($GET(^LAB(61.1,+X,0)),"^",2)_"^SNM^&IMP^^^^MORPH^^^"_Y18
+30 SET IFN2=0
FOR
SET IFN2=$ORDER(^LR(LRDFN,"AY",IFN,2,IFN1,1,IFN2))
IF IFN2<1
QUIT
SET X=^(IFN2,0)
Begin DoDot:3
+31 SET CTR1=CTR1+1
SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)="ETIOLOGY^"_$$POINTER^LR7OB63(63.23,.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$PIECE($GET(^LAB(61.2,+X,0)),"^",2)_"^SNM^^^^^ETIOLOGY^^^"_Y18
End DoDot:3
End DoDot:2
+32 DO PTR(3,"FUNCTION",63.25,.01,61.3,"")
+33 DO PTR(4,"PROCEDURE",63.24,.01,61.5,"&CNP")
+34 SET IFN1=0
FOR
SET IFN1=$ORDER(^LR(LRDFN,"AY",IFN,5,IFN1))
IF IFN1<1
QUIT
SET X=^(IFN1,0)
SET IFN2=0
FOR
SET IFN2=$ORDER(^LR(LRDFN,"AY",IFN,5,IFN1,1,IFN2))
IF IFN2<1
QUIT
SET X1=^(IFN2,0)
Begin DoDot:2
+35 SET CTR1=CTR1+1
SET ^TMP("LRX",$JOB,69,CTR,3,CTR1)="SPECIAL STUDIES "_$$SET^LR7OB63(63.26,.01,$PIECE(X,"^"))_"~"_$PIECE(X,"^",2)_"^"_X1_"^^^^^^TX^^^^^^^SPEC STUDIES "_$$SET^LR7OB63(63.26,.01,$PIECE(X,"^"))_"~"_$PIECE(X,"^",2)_"^^^"_Y18
End DoDot:2
End DoDot:1
+36 QUIT
WP(I,NAME,ID,VALTYP) ;Store word processing fields
+1 ;I=Node at ^LR(LRDFN,I)
+2 ;NAME=Field name
+3 ;ID=Coded HL7 ID
+4 ;VALTYP="TX" for text, "CE" for coded
+5 NEW IFN,IFN1,X
+6 IF 'I
QUIT
IF '$LENGTH(NAME)
QUIT
+7 SET IFN=0
FOR
SET IFN=$ORDER(^LR(LRDFN,I,IFN))
IF IFN<1
QUIT
SET X=^(IFN,0)
DO SPLIT^LR7OU1(X,"^TMP(""LRX"",$J,69,CTR,63)",.CTR1,80,NAME_"^","^^^^"_Y6_"^^"_VALTYP_"^^^"_ID_"^^^^"_NAME_"^^^"_Y18)
+8 QUIT
PTR(I,NAME,FILE,FIELD,SNMFILE,ID) ;Store ptr fields for ORGAN/TISSUE multiple
+1 ;I=Node at ^LR(LRDFN,'AY',IFN,I)
+2 ;NAME=Field name
+3 ;FILE=File #
+4 ;FIELD=Field #
+5 ;SNMFILE=Snomed file # for coded entry
+6 ;ID=Procedure ID Natl
+7 NEW IFN1
+8 IF 'I
QUIT
IF '$LENGTH(NAME)
QUIT
+9 SET IFN1=0
FOR
SET IFN1=$ORDER(^LR(LRDFN,"AY",IFN,I,IFN1))
IF IFN1<1
QUIT
SET X=^(IFN1,0)
Begin DoDot:1
+10 SET CTR1=CTR1+1
SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)=NAME_"^"_$$POINTER^LR7OB63(FILE,FIELD,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$PIECE($GET(@("^LAB("_SNMFILE_","_+X_",0)")),"^",2)_"^SNM^"_ID_"^^^^"_NAME_"^^^"_Y18
End DoDot:1
+11 QUIT
OERR ;Call to OE/RR to setup/update order
+1 NEW X,DR
+2 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
SET X=$PIECE(^(0),"^",4)
SET LRSN=$PIECE(^(0),"^",5)
SET X=$SELECT($PIECE($GET(^LRO(69,+X,1,+LRSN,0)),"^",11):"SC",1:"SN")
DO ACC^LR7OB1(LRAA,LRAD,LRAN,X)
+3 QUIT
OE1 ;Get 'before' status of accession
+1 NEW X
+2 SET CORRECT=0
+3 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
SET LRDFN=+^(0)
+4 IF LRSS="AU"
IF $PIECE($GET(^LR(LRDFN,LRSS)),"^",15)
SET CORRECT=1
QUIT
+5 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
QUIT
IF '$PIECE(^(3),"^",5)
QUIT
SET X=$PIECE(^(3),"^",5)
+6 IF $PIECE($GET(^LR(LRDFN,LRSS,X,0)),"^",11)
SET CORRECT=1
+7 QUIT
