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

LRSPRPT1.m

Go to the documentation of this file.
  1. LRSPRPT1 ;AVAMC/REG/WTY - SURG PATH RPT PRINT CONT. ; 17-Oct-2014 09:22 ; MKK
  1. ;;5.2;LAB SERVICE;**1030,1031,1034**;NOV 1, 1997;Build 188
  1. ;
  1. ;;VA LR Patch(s): 1,259,315
  1. ;
  1. ;25-Jul-01;WTY;In line tag L, if being called by LRAPT2, don't do
  1. ; line tag F. Do H1^LRAPT2 instead.
  1. ;21-Aug-01;WTY;Removed call to LRSPRPT2 which prints SNOMED codes.
  1. ;
  1. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
  1. EP ; EP
  1. NEW ACCDATE
  1. ; ----- END IHS/MSC/MKK - LR*5.2*1034
  1. ;
  1. S A=0 F S A=+$O(^LR(LRDFN,LRSS,LRI,2,A)) Q:'A!(LR("Q")) D
  1. .S T=+^LR(LRDFN,LRSS,LRI,2,A,0),X=$S($D(^LAB(61,T,0)):^(0),1:"")
  1. .S T(1)=$P(X,"^"),T(8)=$P(X,"^",2)
  1. .D SP Q:LR("Q")
  1. .D T
  1. Q:LR("Q")
  1. I $D(LRS(99)),'+$G(LR("SPSM")) D ^LRSPRPT2
  1. Q:LR("Q")
  1. I $D(LRS(99)) W ! D
  1. .S A=0 F S A=$O(^LR(LRDFN,LRSS,LRI,3,A)) Q:'A!(LR("Q")) D
  1. ..D:$Y>(IOSL-12) F Q:LR("Q")
  1. ..S X=+^LR(LRDFN,LRSS,LRI,3,A,0)
  1. ..N LRX
  1. ..; S LRX=X,LRX=$$ICDDX^ICDCODE(LRX,,,1)
  1. ..; ----- BEGIN IHS/MSC/MKK - LR*5.2*1034
  1. .. S ACCDATE=+$P($G(^LR(LRDFN,LRSS,LRI,0)),".")
  1. .. S LRX=X,LRX=$$ICDDX^ICDEX(LRX,,,"I",1)
  1. ..; ----- END IHS/MSC/MKK - LR*5.2*1034
  1. ..S X=$P(LRX,U,4)
  1. ..W !,"ICD code: ",$P(LRX,U,2),?20 D:LR(69.2,.05) C^LRUA W X
  1. Q
  1. SP ;
  1. S C=0 F S C=$O(^LR(LRDFN,LRSS,LRI,2,A,5,C)) Q:'C!(LR("Q")) D
  1. .S T(3)=^LR(LRDFN,LRSS,LRI,2,A,5,C,0)
  1. .S Y=$P(T(3),"^",2),E=$P(T(3),"^",3)
  1. .S T(4)=$P(T(3),"^")_":",T(4)=$P($P(LR(LRSS),T(4),2),";",1)
  1. .D D^LRU S T(2)=Y
  1. .D:$Y>(IOSL-12) F Q:LR("Q") D WP
  1. Q
  1. WP ;
  1. W !!,T(4)," ",E," Date: ",T(2)," ",!,T(1),!
  1. D E S B=0
  1. F LRZ=0:1 S B=$O(^LR(LRDFN,LRSS,LRI,2,A,5,C,1,B)) Q:'B!(LR("Q")) D
  1. .D:$Y>(IOSL-12) F Q:LR("Q")
  1. .S X=^LR(LRDFN,LRSS,LRI,2,A,5,C,1,B,0) D ^DIWP
  1. Q:LR("Q") D:LRZ ^DIWW
  1. Q
  1. E ;
  1. K ^UTILITY($J) S DIWR=IOM-10,DIWL=10,DIWF="W"
  1. Q
  1. T ;
  1. S T(3)=T,T(4)=61 D EN
  1. S M=0 F S M=$O(^LR(LRDFN,LRSS,LRI,2,A,2,M)) Q:'M!(LR("Q")) D
  1. .S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,2,M,0),T(4)=61.1 D EN Q:LR("Q") D
  1. ..S N=0 F S N=$O(^LR(LRDFN,LRSS,LRI,2,A,2,M,1,N)) Q:'N!(LR("Q")) D
  1. ...S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,2,M,1,N,0),T(4)=61.2 D EN
  1. Q:LR("Q")
  1. S M=0 F S M=$O(^LR(LRDFN,LRSS,LRI,2,A,1,M)) Q:'M!(LR("Q")) D
  1. .S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,1,M,0),T(4)=61.4 D EN
  1. Q:LR("Q")
  1. S M=0 F S M=$O(^LR(LRDFN,LRSS,LRI,2,A,3,M)) Q:'M!(LR("Q")) D
  1. .S T(3)=+^LR(LRDFN,LRSS,LRI,2,A,3,M,0),T(4)=61.3 D EN
  1. Q
  1. EN ;also from LRAPT2
  1. S C(1)=0
  1. F S C(1)=$O(^LAB(T(4),T(3),"JR",C(1))) Q:'C(1)!(LR("Q")) D
  1. .I $P(^LAB(T(4),T(3),"JR",C(1),0),"^",7) S T(9)=^(0),T(5)=1 D L
  1. Q
  1. L ;
  1. S X=$O(^LAB(T(4),T(3),"JR",C(1),1,0))
  1. I X K T(5) D
  1. .S X=0 F S X=$O(^LAB(T(4),T(3),"JR",C(1),1,X)) Q:'X D
  1. ..S Y=$P(^LAB(T(4),T(3),"JR",C(1),1,X,0),"^")
  1. ..I Y=$E(T(8),1,$L(Y)) S T(5)=1
  1. Q:'$D(T(5))
  1. D PGCHK
  1. Q:LR("Q")
  1. W ! D PGCHK Q:LR("Q")
  1. W !,"Reference: "
  1. D PGCHK Q:LR("Q")
  1. W !,$P(T(9),"^")
  1. D PGCHK Q:LR("Q")
  1. W !,$P(T(9),"^",2)
  1. D PGCHK Q:LR("Q")
  1. W !
  1. I $P(T(9),"^",3) D
  1. .W $P(^LAB(95,$P(T(9),"^",3),0),"^")," vol.",$P(T(9),"^",4)
  1. .W " pg.",$P(T(9),"^",5)
  1. S Y=$P(T(9),"^",6) D D^LRU W " Date: ",Y
  1. Q
  1. F ;
  1. D F^LRAPF,^LRAPF
  1. Q
  1. PGCHK ;
  1. I $Y>(IOSL-12) D
  1. .I LRSS="AU" D Q
  1. ..I '+$G(LRSF515) D H1^LRAPT Q
  1. ..D:+$G(LRSF515) FT^LRAURPT,H^LRAURPT
  1. .D F
  1. Q
  1. END ;
  1. W $C(7),!!,"OK TO DELETE THE ",LRAA(1)," FINAL REPORT LIST"
  1. S %=2 D YN^LRU
  1. I %=1 K ^LRO(69.2,LRAA,2) S ^LRO(69.2,LRAA,2,0)="^69.23A^0^0" D Q
  1. .W $C(7),!,"LIST DELETED !"
  1. W !!,"FINE, LET'S FORGET IT",!
  1. Q