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

LRSPRPT2.m

Go to the documentation of this file.
  1. LRSPRPT2 ;AVAMC/REG/WTY - SURG PATH PRINT SNOMED;09/06/01
  1. ;;5.2;LAB SERVICE;**72,259**;Sep 27, 1994
  1. ;
  1. D:$Y>(IOSL-13) F Q:LR("Q")
  1. I $D(^LR(LRDFN,LRSS,LRI,2,A)) W !,"SNOMED code(s):"
  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),T=^LAB(61,T,0)
  1. .D:$Y>(IOSL-12) F Q:LR("Q")
  1. .W !,"T-",$P(T,"^",2),": "
  1. .S X=$P(T,"^") D:LR(69.2,.05) C^LRUA W X
  1. .D M
  1. Q
  1. M ;
  1. S B=0 F S B=$O(^LR(LRDFN,LRSS,LRI,2,A,2,B)) Q:'B!(LR("Q")) D
  1. .S M=+^LR(LRDFN,LRSS,LRI,2,A,2,B,0),M=^LAB(61.1,M,0)
  1. .D:$Y>(IOSL-12) F Q:LR("Q")
  1. .W !?5,"M-",$P(M,"^",2),": "
  1. .S X=$P(M,"^") D:LR(69.2,.05) C^LRUA W X
  1. .D E
  1. D ;
  1. Q:LR("Q")
  1. F B=1.4,3.3,4.5 D
  1. .S C=0 F S C=$O(^LR(LRDFN,LRSS,LRI,2,A,$P(B,"."),C)) Q:'C!(LR("Q")) D
  1. ..S X=^LR(LRDFN,LRSS,LRI,2,A,$P(B,"."),C,0)
  1. ..D A
  1. Q
  1. A ;
  1. S M=+X,M(2)=$P(X,"^",2),E="61."_$P(B,".",2),M=^LAB(E,M,0)
  1. D:$Y>(IOSL-12) F Q:LR("Q")
  1. W !?5,$S(B=1.4:"D-",B=3.3:"F-",B=4.5:"P-",1:""),$P(M,"^",2),?12,": "
  1. S X=$P(M,"^") D:LR(69.2,.05) C^LRUA W X
  1. I B=4.5,M(2)]"" D W
  1. Q
  1. E ;
  1. S C=0 F S C=$O(^LR(LRDFN,LRSS,LRI,2,A,2,B,1,C)) Q:'C!(LR("Q")) D
  1. .S E=+^LR(LRDFN,LRSS,LRI,2,A,2,B,1,C,0),E=^LAB(61.2,E,0)
  1. .D:$Y>(IOSL-12) F Q:LR("Q")
  1. .W !?10,"E-",$P(E,"^",2),": " S X=$P(E,"^") D:LR(69.2,.05) C^LRUA W X
  1. Q
  1. F ;
  1. D F^LRAPF,^LRAPF
  1. Q
  1. W ;
  1. W " (",$S(M(2)=0:"negative",M(2)=1:"positive",1:"?"),")"
  1. Q
  1. EN ;from LRSPRPT,LRSPT
  1. Q:'LRAPX(1)
  1. W !!,"Add/Delete reports to/from print queue for ",LRH(0)," "
  1. S %=2 D YN^LRU I %=1 D AD
  1. I '$O(^LRO(69.2,LRAA,LRAPX(1),0)) D Q
  1. .W $C(7),!!,"NO ",$S(LRAPX(1)=2:"FINAL",1:"PRELIMINARY")
  1. .W " REPORTS CURRRENTLY ON THE PRINT QUEUE" S %=0
  1. Q
  1. D XR^LRU S LRY=$E(LRAD,1,3),LRY(1)=LRY+1700
  1. I '$O(^LR(LRXREF,LRY,LRABV,0)) D Q
  1. .W $C(7),!,"No accessions for ",LRY(1)
  1. ACC ;
  1. W !!,"Select ",LRO(68)," accession number: " R X:DTIME Q:X=""!(X[U)
  1. I +X'=X W $C(7),!,"Enter NUMBERS only." G ACC
  1. I '$O(^LR(LRXREF,LRY,LRABV,X,0)) D G ACC
  1. .W $C(7),!,"Accession number doesn't exist for ",LRY(1)
  1. S LRDFN=$O(^LR(LRXREF,LRY,LRABV,X,0)),LRI=$O(^(LRDFN,0))
  1. S LRAN=X,X=^LR(LRDFN,0) D ^LRUP W !,LRP," ID: ",SSN
  1. I $D(^LRO(69.2,LRAA,LRAPX(1),LRAN,0)) D DEL G ACC
  1. I LRAPX(1)=2,'$P(^LR(LRDFN,LRSS,LRI,0),"^",3) D G ACC
  1. .W $C(7),!,LRO(68)," Accession ",LRAN," for ",LRH(0),!,"does not "
  1. .W "have a complete date."
  1. W !!,"Add ",LRO(68)," accession ",LRAN," for ",LRY(1)," to"
  1. W !,$S(LRAPX(1)=2:"final",1:"preliminary")," rpt print queue "
  1. S %=2 D YN^LRU D:%=1 ADD
  1. G ACC
  1. DEL ;
  1. W !!,"Delete ",LRO(68)," accession ",LRAN," for ",LRY(1),!,"from "
  1. W $S(LRAPX(1)=2:"final",1:"preliminary")," rpt print queue "
  1. S %=2 D YN^LRU Q:%'=1
  1. K ^LRO(69.2,LRAA,LRAPX(1),LRAN)
  1. L +^LRO(69.2,LRAA,LRAPX(1))
  1. S X=^LRO(69.2,LRAA,LRAPX(1),0)
  1. S X(1)=$O(^LRO(69.2,LRAA,LRAPX(1),0))
  1. S ^LRO(69.2,LRAA,LRAPX(1),0)=$P(X,"^",1,2)_"^"_X(1)_"^"_($P(X,"^",4)-1)
  1. L -^LRO(69.2,LRAA,LRAPX(1))
  1. Q
  1. ADD ;
  1. S ^LRO(69.2,LRAA,LRAPX(1),LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
  1. L +^LRO(69.2,LRAA,LRAPX(1))
  1. S X=^LRO(69.2,LRAA,LRAPX(1),0)
  1. S ^LRO(69.2,LRAA,LRAPX(1),0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
  1. L -^LRO(69.2,LRAA,LRAPX(1))
  1. Q