LRACM3 ;SLC/DCM - REPRINT/INITIALIZE PATIENT CUM REPORT ;6/12/89 16:21 ;
;;5.2;LAB SERVICE;**174,201**;Sep 27, 1994
EN02 ;
PAT D A^LRACM1 I LRNOT D MSG^LRACM
D ASK^LRACM1 S LRRE=1 D LOOP,END^LRACM Q
LOOP K DIC D ^LRDPA Q:LRDFN<1 S LRNM=PNM,LRPAT=1 I '$D(^LAC(LRXLR,LRDFN)) W !!,$C(7),"NO DATA IN CUMULATIVE FILE FOR THIS PATIENT!!!"
D LOC^LRWU
Q:LREND
R !!,"Select (1) Re-initialize/Print patient's entire cumulative",!," (2) Reprint patient's previous cumulative. 2// ",LRTI:DTIME Q:'$T
S:LRTI="" LRTI=2 Q:"12"'[LRTI I LRTI["1" D TIRE Q:Y<0
K IO("Q") S %ZIS="QM" D ^%ZIS Q:POP
I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^LRACM3",ZTSAVE("D*")="",ZTSAVE("LR*")="",ZTSAVE("S*")="",ZTSAVE("U")="" D ^%ZTLOAD,^%ZISC K ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE Q
U IO
DQ D LOAD^LRACM,PT^LRX S LRIDT=0
I LRTI["1" D A,PAT^LRAC1
D:LRTI'["1" LRCALE^LRAC2,ENT^LRAC3,MICRO^LRAC1
W @IOF D ^%ZISC K LRPAT,LREN,LRRE,LRAC D END^LRACM S ZTREQ="@" Q
TIRE W !!?10,$C(7),"** THIS PRINT-OUT MUST BE CHARTED!!! **",! S J=0
S I=0 F S I=$O(^LRO(68,"AC",LRDFN,I)) Q:I<1 S J=I
I J>0 S J=9999999-J W:J>1 !,"STARTING DATE SHOULD AT LEAST GO BACK TO ",$$Y2K^LRX($P(J,".")),".",!,"There is data in the cross-reference back to this date that should be ",!,"on this patient's cumulative.",!
S %DT="AEQ",%DT("A")="ENTER STARTING DATE FOR REINITIALIZATION: " D ^%DT K %DT Q:Y<0 S LRXDT=9999999-Y
Q
A ;
S LRRE=0 K ^LR(LRDFN,"PG"),^LAC(LRXLR,LRDFN),^LAC("LGOT",LRDFN),^LRO(68,"AC",LRDFN),^LRO(68,"MI",LRDFN)
LRIDT S LRIDT=0 F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1!(LRIDT>LRXDT) S $P(^(LRIDT,0),U,9)="" D LRSB
Q:'$D(^LR(LRDFN,"MI")) S LRIDT=0 F S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1!(LRIDT>LRXDT) F LRSB=1,5,8,11,16 I $D(^LR(LRDFN,"MI",LRIDT,LRSB)),'$D(^LRO(68,"MI",LRDFN,LRIDT,LRSB)) S ^(LRSB)="" W ":"
Q
LRSB S LRSB=0 F S LRSB=$O(^LR(LRDFN,"CH",LRIDT,LRSB)) Q:LRSB<1 I '$D(^LRO(68,"AC",LRDFN,LRIDT,LRSB)) S ^(LRSB)="" W "."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRACM3 1952 printed Dec 13, 2024@02:06:27 Page 2
LRACM3 ;SLC/DCM - REPRINT/INITIALIZE PATIENT CUM REPORT ;6/12/89 16:21 ;
+1 ;;5.2;LAB SERVICE;**174,201**;Sep 27, 1994
EN02 ;
PAT DO A^LRACM1
IF LRNOT
DO MSG^LRACM
+1 DO ASK^LRACM1
SET LRRE=1
DO LOOP
DO END^LRACM
QUIT
LOOP KILL DIC
DO ^LRDPA
if LRDFN<1
QUIT
SET LRNM=PNM
SET LRPAT=1
IF '$DATA(^LAC(LRXLR,LRDFN))
WRITE !!,$CHAR(7),"NO DATA IN CUMULATIVE FILE FOR THIS PATIENT!!!"
+1 DO LOC^LRWU
+2 if LREND
QUIT
+3 READ !!,"Select (1) Re-initialize/Print patient's entire cumulative",!," (2) Reprint patient's previous cumulative. 2// ",LRTI:DTIME
if '$TEST
QUIT
+4 if LRTI=""
SET LRTI=2
if "12"'[LRTI
QUIT
IF LRTI["1"
DO TIRE
if Y<0
QUIT
+5 KILL IO("Q")
SET %ZIS="QM"
DO ^%ZIS
if POP
QUIT
+6 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="DQ^LRACM3"
SET ZTSAVE("D*")=""
SET ZTSAVE("LR*")=""
SET ZTSAVE("S*")=""
SET ZTSAVE("U")=""
DO ^%ZTLOAD
DO ^%ZISC
KILL ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE
QUIT
+7 USE IO
DQ DO LOAD^LRACM
DO PT^LRX
SET LRIDT=0
+1 IF LRTI["1"
DO A
DO PAT^LRAC1
+2 if LRTI'["1"
DO LRCALE^LRAC2
DO ENT^LRAC3
DO MICRO^LRAC1
+3 WRITE @IOF
DO ^%ZISC
KILL LRPAT,LREN,LRRE,LRAC
DO END^LRACM
SET ZTREQ="@"
QUIT
TIRE WRITE !!?10,$CHAR(7),"** THIS PRINT-OUT MUST BE CHARTED!!! **",!
SET J=0
+1 SET I=0
FOR
SET I=$ORDER(^LRO(68,"AC",LRDFN,I))
if I<1
QUIT
SET J=I
+2 IF J>0
SET J=9999999-J
if J>1
WRITE !,"STARTING DATE SHOULD AT LEAST GO BACK TO ",$$Y2K^LRX($PIECE(J,".")),".",!,"There is data in the cross-reference back to this date that should be ",!,"on this patient's cumulative.",!
+3 SET %DT="AEQ"
SET %DT("A")="ENTER STARTING DATE FOR REINITIALIZATION: "
DO ^%DT
KILL %DT
if Y<0
QUIT
SET LRXDT=9999999-Y
+4 QUIT
A ;
+1 SET LRRE=0
KILL ^LR(LRDFN,"PG"),^LAC(LRXLR,LRDFN),^LAC("LGOT",LRDFN),^LRO(68,"AC",LRDFN),^LRO(68,"MI",LRDFN)
LRIDT SET LRIDT=0
FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
if LRIDT<1!(LRIDT>LRXDT)
QUIT
SET $PIECE(^(LRIDT,0),U,9)=""
DO LRSB
+1 if '$DATA(^LR(LRDFN,"MI"))
QUIT
SET LRIDT=0
FOR
SET LRIDT=$ORDER(^LR(LRDFN,"MI",LRIDT))
if LRIDT<1!(LRIDT>LRXDT)
QUIT
FOR LRSB=1,5,8,11,16
IF $DATA(^LR(LRDFN,"MI",LRIDT,LRSB))
IF '$DATA(^LRO(68,"MI",LRDFN,LRIDT,LRSB))
SET ^(LRSB)=""
WRITE ":"
+2 QUIT
LRSB SET LRSB=0
FOR
SET LRSB=$ORDER(^LR(LRDFN,"CH",LRIDT,LRSB))
if LRSB<1
QUIT
IF '$DATA(^LRO(68,"AC",LRDFN,LRIDT,LRSB))
SET ^(LRSB)=""
WRITE "."
+1 QUIT
