- 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
