source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRAC1.m@ 1596

LRAC1 ;SLC/DCM/MILW/JMC - CUMULATIVE CONT. ;2/19/91  09:55 ;
 ;;5.2;LAB SERVICE;;Sep 27, 1994
LRDFN S LRTNN=2
 F LRDFN=LRDFN:0 S LRDFN=$O(^LRO(69,LRDT,1,"AR",LRLLOC,LRNM,LRDFN)) K LRTRUE Q:LRDFN<1  I LRRE!('^(LRDFN)) S LRIL=1 D PAT S:LRLLOC["FILE ROOM" ^TMP($J,"SSN",$S(LRDPF=2:"A"_$E(SSN,10,11)_$E(SSN,8,9)_$E(SSN,1,3)_$E(SSN,5,6),1:LRNM),LRDFN)=""
 Q
PAT ;from LRACM3
 Q:$D(^LR(LRDFN,0))[0
 S DFN=$P(^LR(LRDFN,0),U,3),LRDPF=+$P(^(0),U,2)
 D PT^LRX Q:LRLLOC["FILE ROOM"  S SSN=" "_SSN_" "
PAT1 ;from LRACFILE
 L +^LAC(LRXLR,LRDFN) I '$D(^LAC(LRXLR,LRDFN,0)) S ^(0)=LRDFN,^LAC(LRXLR,"B",LRDFN,LRDFN)="",LRZO="^LAC("""_LRXLR_""",",LRZ1=64.7,LRZ3=LRDFN D Z^LRWU
 S:'$D(^LAC(LRXLR,LRDFN,"MISC",1,0)) ^(0)="MISCELLANEOUS TESTS^"
 D:'$D(LRCALE) LRCALE^LRAC2 DO:'LRRE FIDT DO ENT^LRAC3 K LRMISC
 I 'LRRE S $P(^LAC(LRXLR,LRDFN,0),U,2)=LRDT S:$D(LRRPTN) $P(^LAB(64.5,1,3,LRRPTN,0),U,4,6)=LRLLOC_U_LRNM_U_LRDFN S $P(^LRO(69,LRDT,1,"AR",LRLLOC,LRNM,LRDFN),U)=1
 L -^LAC(LRXLR,LRDFN)
MICRO ;from LRACM3
 Q:'$D(^LRO(68,"MI",LRDFN))
 S LRZ=$P(^LAB(64.5,1,0),U,5)
 S:'$D(LRUNKNOW) LRUNKNOW=$P(^LAB(69.9,1,1),U,5)
 S (LRONESPC,LRONETST)="",LREND=0
 S LRWRDVEW="",LRSB=0 S LRIDT=0
 F  S LRIDT=$O(^LRO(68,"MI",LRDFN,LRIDT)) G:LRIDT<1 MIEND D ZIP,FORP
FORP I $D(^LR(LRDFN,"MI",LRIDT,0)) S LRII=0 F  S LRII=$O(^LRO(68,"MI",LRDFN,LRIDT,LRII)) Q:LRII<1  I $D(^LR(LRDFN,"MI",LRIDT,LRII)) S LRSB=LRII,LRZA=$P(^(LRII),U,2) D:(LRZ="F"&(LRZA="F"))!(LRZ="P") EN1^LRMIPC D FORP1
 Q
FORP1 S LRLLOC=LRNLOC S:'LRRE ^LAC("LRKILL",LRDFN,"MI",LRIDT,LRII)="",^LRO(68,"MI",LRDFN,LRIDT,LRII)=1
 Q
MIEND K %,A,A1,AGE,B,B1,DFN,DOB,DZ,I,J,LR2ORMOR,LRAA,LRACC,LRACN,LRAD,LRADM
 K LRADX,LRAFS,LRAX,LRBUG,LRCMNT,LRCOMTAB,LRCS,LRDCOM,LREF,LREND,LRIFN
 K LRLLT,LRMD,LRNLOC,LRNS,LROK,LRONESPC,LRONETST,LRORG,LRPRE,LRPRINT
 K LRPG,LRQU,LRRC,LRSPEC,LRSPZ,LRSSD,LRST,LRTK,LRTS,LRTSTS,LRTUS,LRUS
 K LRWRD,LRZ,LRZA,P,SEX,SSN,X,Y
 Q
FIDT S LRIDT=0
 F  S LRIDT=$O(^LRO(68,"AC",LRDFN,LRIDT)) Q:LRIDT<1  D LRIDT^LRAC2
 Q
LRLTR ;from LRACM
 I $D(LRLOCB) S Y=$S(LRLOCB?1N.N&(LRLLOC?1N.N):1,LRLOCB?1N.N&(LRLLOC'?1N.N):2,LRLOCB'?1N.N&(LRLLOC'?1N.N):3,1:4) Q:Y=1&(LRLLOC>LRLOCB)!(Y=2)!(Y=3&(LRLLOC]LRLOCB))
 I LRLLOC["FILE ROOM",'LRRE,$P($G(^LAB(64.5,1,6)),U,2),'$P($G(^LAB(64.5,1,3,LRRPTN,.1)),U,3) Q
 ; If location contains "FILE ROOM", not a reprint, site using separate file room, and not a file room report then quit.
 W @IOF S LRLTR=$E(LRLLOC,1,4) D ^LRLTR S:'$D(LRTRUE) LRNM=-1
 D LRNM D:LRLLOC["FILE ROOM" ENT^LRACFILE Q
LRNM F Q=0:0 S:'$D(LRTRUE) LRNM=$O(^LRO(69,LRDT,1,"AR",LRLLOC,LRNM)) Q:LRNM=""  S:'$D(LRTRUE) LRDFN=0 D LRDFN I $D(LRNMA) Q:LRNMA=LRNM
 Q
ZIP I '$D(^LR(LRDFN,"MI",LRIDT,0)) K ^LRO(68,"MI",LRDFN,LRIDT) Q
 S LRNLOC=LRLLOC
 Q
LRLLOC F Q=0:0 S:'$D(LRTRUE) LRLLOC=$O(^LRO(69,LRDT,1,"AR",LRLLOC)) Q:LRLLOC=""  D LRLTR
 Q
ENT ;from LRACM1
 S:$D(ZTQUEUED) ZTREQ="@"
 I $D(IOP) S LRX=$S($D(DUZ(0)):DUZ(0),1:""),DUZ(0)="" D ^%ZIS S DUZ(0)=LRX K IOP
 I 'LRRE,'$P(^LAB(64.5,1,3,LRRPTN,0),U,7) S %DT="T",X="N" D ^%DT S $P(^LAB(64.5,1,3,LRRPTN,0),U,7)=Y
 U IO K ^TMP($J) D DT^LRX S LRCDT=LRDT0,LRAC=1
 G:LRRE DO S X=$P(^LAB(64.5,1,3,LRRPTN,0),U,4,8),Y=^(0),LRLLOC=$S(LRDT=LRLDT&($L($P(X,U,1))):$P(X,U,1),1:$P(Y,U,2)),LRLOCB=$P(Y,U,3)
 S LRNM=$S(LRDT=LRLDT&($L($P(X,U,2))):$P(X,U,2),1:-1)
 S LRDFN=$S(LRDT=LRLDT:$P(X,U,3),1:0)
 I $L(LRLLOC),$D(^LRO(69,LRDT,1,"AR",LRLLOC)) S LRTRUE=1
DO DO LRLLOC
END S LRLTR="END" W @IOF D ^LRLTR
 I '$D(LREN),'LRRE,'$P(^LAB(64.5,1,3,LRRPTN,0),U,8) S %DT="T",X="N" D ^%DT S $P(^LAB(64.5,1,3,LRRPTN,0),U,8)=Y
 D KILL K ^TMP($J),^TMP("LRLTR",$J) D ^%ZISC
 Q
KILL K LRG,LRADD,LRCNT,LRCTN,LRCTR,LRCTRR,LRDT,LRDT1,LRFALT,LRFD1,LRFDE
 K LRFFDT,LRIF,LRIPG,LRIV,LRKL,LRLTR,LRNOT,LRNUM,LRNX,LRNXSW,LRPG2,LRPPT
 K LRVAR,LRXLR,LRYDT,LRRPTN,X1,LRJ02
 Q