LRAPPF1 ;AVAMC/REG/WTY - ANAT PATH FILE PRINT BY PT ;10/16/01
;;5.2;LAB SERVICE;**1002,1003,1006,1031**;NOV 1, 1997
;
;;VA LR Patche(s): 72,173,201,259,362,392
;
;Reference to ^DIC supported by IA #916
;
S F=0 F S F=$O(^TMP($J,F)) Q:'F!(LR("Q")) D
.S F(1)=$P(^DIC(F,0),"^"),F(2)=^DIC(F,0,"GL")
.K LR("F") D H S LR("F")=1 D W
Q:LR("Q")
D ^LRAPPF2
Q
W S W=0 F LRB=0:0 S W=$O(^TMP($J,F,W)) Q:W=""!(LR("Q")) D LR
Q
LR F LRDFN=0:0 S LRDFN=$O(^TMP($J,F,W,LRDFN)) Q:'LRDFN!(LR("Q")) D NM
Q
NM S X=^LR(LRDFN,0),LRDPF=$P(X,U,2),N=$P(X,"^",3),N=@(F(2)_N_",0)")
S LRP=$P(N,"^"),SSN=$P(N,"^",9),Y=$P(N,"^",3)
D D^LRU,SSN^LRU S DOB=$S(Y'[1700:Y,1:"")
D:$Y>(IOSL-4) H Q:LR("Q")
; W !!,LRP,?31,SSN W:$L(DOB) ?51,"BORN: ",DOB
W !!,LRP,?31,HRCN W:$L(DOB) ?51,"BORN: ",DOB ; IHS/MSC/MKK - LR*5.2*1031
S LRI=0 F S LRI=$O(^TMP($J,F,W,LRDFN,LRI)) Q:'LRI!(LR("Q")) D
.D @($S("CYEMSP"[LRSS:"EN",1:"AUT"))
Q
AUT S LRSF515=+$G(LRSF515)
D:$Y>(IOSL-12) H1 Q:LR("Q")
S X=^LR(LRDFN,"AU"),N=$P(X,"^",6),Y=+X D D^LRU S LRH(3)=Y,DA=LRDFN
D D^LRAUAW S Y=LR(63,12) D D^LRU S E=Y,H(2)=$E(H(1),1,3)
W !,"AUTOPSY #: ",N," AUTOPSY DATE: ",LRH(3),?51,"DIED: ",E
D EN^LRAPT2
S X=0 F S X=$O(^LR(LRDFN,"AY",X)) Q:'X!(LR("Q")) D
.S Y=+^LR(LRDFN,"AY",X,0),Y=$S($D(^LAB(61,Y,0)):$P(^(0),"^"),1:Y)
.W !,Y D AM
Q
AM S M=0 F S M=$O(^LR(LRDFN,"AY",X,2,M)) Q:'M!(LR("Q")) D
.S Y=+^LR(LRDFN,"AY",X,2,M,0)
.S Y=$S($D(^LAB(61.1,Y,0)):$P(^(0),"^"),1:Y)
.W !?5,Y
Q
;
EN ;from LRAPT1,LRAPQACN
S LRSF515=+$G(LRSF515) ;Indicates that this is generating an SF515
S X=$G(^LR(LRDFN,S,LRI,0)) Q:X="" S LR("PATH")=$P(X,U,2),N=$P(X,U,6)
S N(11)=$P(X,U,11),X=$P(X,U,10),X=$P(X,"."),LRH(3)=$$Y2K^LRX(X)
S H(2)=$E(X,1,3)
I LR("PATH")]"" D
.S LR("PATH")=$$EXTERNAL^DILFD(LRSF,.02,"",LR("PATH"),LR("PATH"))
S:N="" N="?" S:'H(2) H(2)="?"
I LRSF515 D:$Y>(IOSL-13) F^LRAPF,^LRAPF
I 'LRSF515 D:$Y>(IOSL-4) H1
Q:LR("Q")
W !?2,"Organ/tissue:",?17,"Date rec'd: ",LRH(3),?43,"Acc #:",N
W ?64,$E(LR("PATH"),1,12)
I 'N(11) W !?5,"Report not verified." Q
;SNOMED codes
I '+$G(LR("SPSM")) D Q:LR("Q")
.S O=0 F S O=$O(^LR(LRDFN,S,LRI,2,O)) Q:'O!(LR("Q")) D
..D:$Y>(IOSL-4) H2
..Q:LR("Q")
..S X=^LR(LRDFN,S,LRI,2,O,0),W(3)=$P(X,"^",3)
..S O(6)=$P(^LAB(61,+X,0),"^")
..W !?5,O(6) W:W(3) " ",W(3)," gm" D L
;Comments
I $D(LRQ(3)) D
.S B=0 F S B=$O(^LR(LRDFN,S,LRI,99,B)) Q:'B!(LR("Q")) D
..W !?5,$E(^LR(LRDFN,S,LRI,99,B,0),1,74)
..I LRSF515 D:$Y>(IOSL-13) F^LRAPF,^LRAPF
Q
L S B=0 F S B=$O(^LR(LRDFN,S,LRI,2,O,3,B)) Q:'B!(LR("Q")) D
.S B(1)=+^LR(LRDFN,S,LRI,2,O,3,B,0)
.D:$Y>(IOSL-4) H3 Q:LR("Q")
.W !?10,$P(^LAB(61.3,B(1),0),"^")
S B=0 F S B=$O(^LR(LRDFN,S,LRI,2,O,4,B)) Q:'B!(LR("Q")) D
.S X=^LR(LRDFN,S,LRI,2,O,4,B,0),B(1)=+X,B(2)=$P(X,"^",2)
.D:$Y>(IOSL-4) H3 Q:LR("Q")
.W !?10,$P(^LAB(61.5,B(1),0),"^")
.W:B(2)]"" " (",$S(B(2)=0:"Negative",B(2)=1:"Positive",1:"?"),")"
S B=0 F S B=$O(^LR(LRDFN,S,LRI,2,O,1,B)) Q:'B!(LR("Q")) D
.S B(1)=+^LR(LRDFN,S,LRI,2,O,1,B,0)
.D:$Y>(IOSL-4) H3 Q:LR("Q")
.W !?10,$P(^LAB(61.4,B(1),0),"^")
S M=0 F S M=$O(^LR(LRDFN,S,LRI,2,O,2,M)) Q:'M!(LR("Q")) D
.S M(1)=+^LR(LRDFN,S,LRI,2,O,2,M,0)
.D:$Y>(IOSL-4) H3 Q:LR("Q")
.W !?10,$P(^LAB(61.1,M(1),0),"^") D E
S E=0 F S E=$O(^LR(LRDFN,S,LRI,2,O,5,E)) Q:'E!(LR("Q")) D
.S E(1)=^LR(LRDFN,S,LRI,2,O,5,E,0) D A
Q
A S Y=$P(E(1),"^",2),E(3)=$P(E(1),"^",3),E(4)=$P(E(1),"^")_":"
S E(4)=$P($P(LR(S),E(4),2),";") D D^LRU S E(2)=Y D D^LRU
D:$Y>(IOSL-12) H3 Q:LR("Q")
W !?5,E(4)," ",E(3)," Date: ",E(2)
Q
;
E S E=0 F S E=$O(^LR(LRDFN,S,LRI,2,O,2,M,1,E)) Q:'E!(LR("Q")) D
.W !?12,$P(^LAB(61.2,+^LR(LRDFN,S,LRI,2,O,2,M,1,E,0),0),"^")
Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
Q:$A(IOST)'=80 I $D(LRQ(2)) D H^LRSPT Q
I $D(LRQ(9)) D H^LRAPT1 Q
D F^LRU W !,LRO(68)," "
W:F(2)'="^DPT(" !,"Demographic data in ",F(1)," file."
W !,"Entries listed by PATIENT (From: ",LRSTR," to: ",LRLST,")"
W !,"Name",?31,"Identifier"
W !,LR("%")
Q
H1 Q:$A(IOST)'=80
; D H W:'$D(LRQ(9)) !,LRP,?30,SSN,?42,DOB
D H W:'$D(LRQ(9)) !,LRP,?30,HRCN,?42,DOB ; IHS/MSC/MKK - LR*5.2*1031
Q
H2 Q:$A(IOST)'=80 D H1
W !?5,"Organ/tissue:",?25,"Date received: ",LRH(3),?51,"Acc #:",N
Q
H3 Q:$A(IOST)'=80 D H2
W !?5,O(6) W:W(3) " ",W(3)," gm"
Q
LRAPPF1 ;AVAMC/REG/WTY - ANAT PATH FILE PRINT BY PT ;10/16/01
+1 ;;5.2;LAB SERVICE;**1002,1003,1006,1031**;NOV 1, 1997
+2 ;
+3 ;;VA LR Patche(s): 72,173,201,259,362,392
+4 ;
+5 ;Reference to ^DIC supported by IA #916
+6 ;
+7 SET F=0
FOR
SET F=$ORDER(^TMP($JOB,F))
IF 'F!(LR("Q"))
QUIT
Begin DoDot:1
+8 SET F(1)=$PIECE(^DIC(F,0),"^")
SET F(2)=^DIC(F,0,"GL")
+9 KILL LR("F")
DO H
SET LR("F")=1
DO W
End DoDot:1
+10 IF LR("Q")
QUIT
+11 DO ^LRAPPF2
+12 QUIT
W SET W=0
FOR LRB=0:0
SET W=$ORDER(^TMP($JOB,F,W))
IF W=""!(LR("Q"))
QUIT
DO LR
+1 QUIT
LR FOR LRDFN=0:0
SET LRDFN=$ORDER(^TMP($JOB,F,W,LRDFN))
IF 'LRDFN!(LR("Q"))
QUIT
DO NM
+1 QUIT
NM SET X=^LR(LRDFN,0)
SET LRDPF=$PIECE(X,U,2)
SET N=$PIECE(X,"^",3)
SET N=@(F(2)_N_",0)")
+1 SET LRP=$PIECE(N,"^")
SET SSN=$PIECE(N,"^",9)
SET Y=$PIECE(N,"^",3)
+2 DO D^LRU
DO SSN^LRU
SET DOB=$SELECT(Y'[1700:Y,1:"")
+3 IF $Y>(IOSL-4)
DO H
IF LR("Q")
QUIT
+4 ; W !!,LRP,?31,SSN W:$L(DOB) ?51,"BORN: ",DOB
+5 ; IHS/MSC/MKK - LR*5.2*1031
WRITE !!,LRP,?31,HRCN
IF $LENGTH(DOB)
WRITE ?51,"BORN: ",DOB
+6 SET LRI=0
FOR
SET LRI=$ORDER(^TMP($JOB,F,W,LRDFN,LRI))
IF 'LRI!(LR("Q"))
QUIT
Begin DoDot:1
+7 DO @($SELECT("CYEMSP"[LRSS:"EN",1:"AUT"))
End DoDot:1
+8 QUIT
AUT SET LRSF515=+$GET(LRSF515)
+1 IF $Y>(IOSL-12)
DO H1
IF LR("Q")
QUIT
+2 SET X=^LR(LRDFN,"AU")
SET N=$PIECE(X,"^",6)
SET Y=+X
DO D^LRU
SET LRH(3)=Y
SET DA=LRDFN
+3 DO D^LRAUAW
SET Y=LR(63,12)
DO D^LRU
SET E=Y
SET H(2)=$EXTRACT(H(1),1,3)
+4 WRITE !,"AUTOPSY #: ",N," AUTOPSY DATE: ",LRH(3),?51,"DIED: ",E
+5 DO EN^LRAPT2
+6 SET X=0
FOR
SET X=$ORDER(^LR(LRDFN,"AY",X))
IF 'X!(LR("Q"))
QUIT
Begin DoDot:1
+7 SET Y=+^LR(LRDFN,"AY",X,0)
SET Y=$SELECT($DATA(^LAB(61,Y,0)):$PIECE(^(0),"^"),1:Y)
+8 WRITE !,Y
DO AM
End DoDot:1
+9 QUIT
AM SET M=0
FOR
SET M=$ORDER(^LR(LRDFN,"AY",X,2,M))
IF 'M!(LR("Q"))
QUIT
Begin DoDot:1
+1 SET Y=+^LR(LRDFN,"AY",X,2,M,0)
+2 SET Y=$SELECT($DATA(^LAB(61.1,Y,0)):$PIECE(^(0),"^"),1:Y)
+3 WRITE !?5,Y
End DoDot:1
+4 QUIT
+5 ;
EN ;from LRAPT1,LRAPQACN
+1 ;Indicates that this is generating an SF515
SET LRSF515=+$GET(LRSF515)
+2 SET X=$GET(^LR(LRDFN,S,LRI,0))
IF X=""
QUIT
SET LR("PATH")=$PIECE(X,U,2)
SET N=$PIECE(X,U,6)
+3 SET N(11)=$PIECE(X,U,11)
SET X=$PIECE(X,U,10)
SET X=$PIECE(X,".")
SET LRH(3)=$$Y2K^LRX(X)
+4 SET H(2)=$EXTRACT(X,1,3)
+5 IF LR("PATH")]""
Begin DoDot:1
+6 SET LR("PATH")=$$EXTERNAL^DILFD(LRSF,.02,"",LR("PATH"),LR("PATH"))
End DoDot:1
+7 IF N=""
SET N="?"
IF 'H(2)
SET H(2)="?"
+8 IF LRSF515
IF $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
+9 IF 'LRSF515
IF $Y>(IOSL-4)
DO H1
+10 IF LR("Q")
QUIT
+11 WRITE !?2,"Organ/tissue:",?17,"Date rec'd: ",LRH(3),?43,"Acc #:",N
+12 WRITE ?64,$EXTRACT(LR("PATH"),1,12)
+13 IF 'N(11)
WRITE !?5,"Report not verified."
QUIT
+14 ;SNOMED codes
+15 IF '+$GET(LR("SPSM"))
Begin DoDot:1
+16 SET O=0
FOR
SET O=$ORDER(^LR(LRDFN,S,LRI,2,O))
IF 'O!(LR("Q"))
QUIT
Begin DoDot:2
+17 IF $Y>(IOSL-4)
DO H2
+18 IF LR("Q")
QUIT
+19 SET X=^LR(LRDFN,S,LRI,2,O,0)
SET W(3)=$PIECE(X,"^",3)
+20 SET O(6)=$PIECE(^LAB(61,+X,0),"^")
+21 WRITE !?5,O(6)
IF W(3)
WRITE " ",W(3)," gm"
DO L
End DoDot:2
End DoDot:1
IF LR("Q")
QUIT
+22 ;Comments
+23 IF $DATA(LRQ(3))
Begin DoDot:1
+24 SET B=0
FOR
SET B=$ORDER(^LR(LRDFN,S,LRI,99,B))
IF 'B!(LR("Q"))
QUIT
Begin DoDot:2
+25 WRITE !?5,$EXTRACT(^LR(LRDFN,S,LRI,99,B,0),1,74)
+26 IF LRSF515
IF $Y>(IOSL-13)
DO F^LRAPF
DO ^LRAPF
End DoDot:2
End DoDot:1
+27 QUIT
L SET B=0
FOR
SET B=$ORDER(^LR(LRDFN,S,LRI,2,O,3,B))
IF 'B!(LR("Q"))
QUIT
Begin DoDot:1
+1 SET B(1)=+^LR(LRDFN,S,LRI,2,O,3,B,0)
+2 IF $Y>(IOSL-4)
DO H3
IF LR("Q")
QUIT
+3 WRITE !?10,$PIECE(^LAB(61.3,B(1),0),"^")
End DoDot:1
+4 SET B=0
FOR
SET B=$ORDER(^LR(LRDFN,S,LRI,2,O,4,B))
IF 'B!(LR("Q"))
QUIT
Begin DoDot:1
+5 SET X=^LR(LRDFN,S,LRI,2,O,4,B,0)
SET B(1)=+X
SET B(2)=$PIECE(X,"^",2)
+6 IF $Y>(IOSL-4)
DO H3
IF LR("Q")
QUIT
+7 WRITE !?10,$PIECE(^LAB(61.5,B(1),0),"^")
+8 IF B(2)]""
WRITE " (",$SELECT(B(2)=0:"Negative",B(2)=1:"Positive",1:"?"),")"
End DoDot:1
+9 SET B=0
FOR
SET B=$ORDER(^LR(LRDFN,S,LRI,2,O,1,B))
IF 'B!(LR("Q"))
QUIT
Begin DoDot:1
+10 SET B(1)=+^LR(LRDFN,S,LRI,2,O,1,B,0)
+11 IF $Y>(IOSL-4)
DO H3
IF LR("Q")
QUIT
+12 WRITE !?10,$PIECE(^LAB(61.4,B(1),0),"^")
End DoDot:1
+13 SET M=0
FOR
SET M=$ORDER(^LR(LRDFN,S,LRI,2,O,2,M))
IF 'M!(LR("Q"))
QUIT
Begin DoDot:1
+14 SET M(1)=+^LR(LRDFN,S,LRI,2,O,2,M,0)
+15 IF $Y>(IOSL-4)
DO H3
IF LR("Q")
QUIT
+16 WRITE !?10,$PIECE(^LAB(61.1,M(1),0),"^")
DO E
End DoDot:1
+17 SET E=0
FOR
SET E=$ORDER(^LR(LRDFN,S,LRI,2,O,5,E))
IF 'E!(LR("Q"))
QUIT
Begin DoDot:1
+18 SET E(1)=^LR(LRDFN,S,LRI,2,O,5,E,0)
DO A
End DoDot:1
+19 QUIT
A SET Y=$PIECE(E(1),"^",2)
SET E(3)=$PIECE(E(1),"^",3)
SET E(4)=$PIECE(E(1),"^")_":"
+1 SET E(4)=$PIECE($PIECE(LR(S),E(4),2),";")
DO D^LRU
SET E(2)=Y
DO D^LRU
+2 IF $Y>(IOSL-12)
DO H3
IF LR("Q")
QUIT
+3 WRITE !?5,E(4)," ",E(3)," Date: ",E(2)
+4 QUIT
+5 ;
E SET E=0
FOR
SET E=$ORDER(^LR(LRDFN,S,LRI,2,O,2,M,1,E))
IF 'E!(LR("Q"))
QUIT
Begin DoDot:1
+1 WRITE !?12,$PIECE(^LAB(61.2,+^LR(LRDFN,S,LRI,2,O,2,M,1,E,0),0),"^")
End DoDot:1
+2 QUIT
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
IF LR("Q")
QUIT
+1 IF $ASCII(IOST)'=80
QUIT
IF $DATA(LRQ(2))
DO H^LRSPT
QUIT
+2 IF $DATA(LRQ(9))
DO H^LRAPT1
QUIT
+3 DO F^LRU
WRITE !,LRO(68)," "
+4 IF F(2)'="^DPT("
WRITE !,"Demographic data in ",F(1)," file."
+5 WRITE !,"Entries listed by PATIENT (From: ",LRSTR," to: ",LRLST,")"
+6 WRITE !,"Name",?31,"Identifier"
+7 WRITE !,LR("%")
+8 QUIT
H1 IF $ASCII(IOST)'=80
QUIT
+1 ; D H W:'$D(LRQ(9)) !,LRP,?30,SSN,?42,DOB
+2 ; IHS/MSC/MKK - LR*5.2*1031
DO H
IF '$DATA(LRQ(9))
WRITE !,LRP,?30,HRCN,?42,DOB
+3 QUIT
H2 IF $ASCII(IOST)'=80
QUIT
DO H1
+1 WRITE !?5,"Organ/tissue:",?25,"Date received: ",LRH(3),?51,"Acc #:",N
+2 QUIT
H3 IF $ASCII(IOST)'=80
QUIT
DO H2
+1 WRITE !?5,O(6)
IF W(3)
WRITE " ",W(3)," gm"
+2 QUIT
