LRFAC ;MILW/JMC/DALISC/FHS - CUM PRINT FOR FILEROOM PATIENTS TO SEPARATE PRINTER
;;5.2;LAB SERVICE;;Sep 27, 1994
EN ; Entry point from menu option to manually task file room cumulative.
W @IOF,!!?20,"Checking File #64.5, LAB REPORTS FILE"
D CHECK I LRERR W !!,$C(7),$P(LRERR,U,2),!! G END
W !,"File Setup ...OK",!!,"Will schedule report(s):"
S LRRPTN=0
F S LRRPTN=$O(LRRP(LRRPTN)) Q:'LRRPTN W ?25,$P(LRRP(LRRPTN),U),!
K DIR
S DIR(0)="YO",DIR("A")="Print Cumulative for FILE ROOM",DIR("B")="NO"
S DIR("?")="Answer 'YES' if you want to task the FILE ROOM Cumulative to start."
D ^DIR K DIR
I Y D
. S ZTRTN="CLOCK^LRFAC",ZTIO="",ZTDESC="Start FILE ROOM Cumulative"
. D ^%ZTLOAD W !,"Request ",$S($D(ZTSK):"",1:"NOT "),"Queued" W:$D(ZTSK) !,"Task #",ZTSK
G END
;
CLOCK ; Task fileroom patients cumulative to appropiate devices.
D CHECK I LRERR D G END
. S XQAMSG="File setup problem observed when attempting to run Lab File Room Cumulative"
. D ALERT
K ^LAC($J),XQAMSG
Q:'$D(^LAB(64.5,1,3))!($D(^LAC("LRAC","A")))
S CNT=0 F L +^LAB(64.5):1 Q:$T H 60 S CNT=1 I CNT>5 D Q ; Lock LAB REPORTS file.
. S XQAMSG="Unable to lock Lab Reports file (#64.5) check Lock Table"
. D ALERT
G END:$D(XQAMSG)
S LRDT=$P(^LAB(64.5,1,0),U,3) ; Get last cumulative report date.
S LRLDT=$P($G(^LAB(64.5,1,6)),U,1) I 'LRLDT S LRLDT=LRDT ;Find last fileroom report date ( if none, set to last report date).
S LRRE=0,LRXLR="LRAC",LRPERM=0,LRBOT=$P(^LAB(64.5,1,0),U,2)
S %DT="",X="T" D ^%DT S LRYDT=Y
; For each day since last fileroom run, move fileroom patients to current fileroom list.
; Start with last file room run date in case last run was incomplete.
; If patient has been printed subsequently - date stored in second piece of ^LAC("LRAC",LRDFN,0) is more recent, then skip.
S LRLDT=LRLDT-.1
F S LRLDT=$O(^LRO(69,LRLDT)) Q:'LRLDT!(LRLDT'<LRDT) D
. S LRLLOC="FILE ROOM" ; Start with locations containing "FILE ROOM", end when doesn't contain "FILE ROOM".
. F S LRLLOC=$O(^LRO(69,LRLDT,1,"AR",LRLLOC)) Q:LRLLOC=""!(LRLLOC'["FILE ROOM") D
. . S PNM=""
. . F S PNM=$O(^LRO(69,LRLDT,1,"AR",LRLLOC,PNM)) Q:PNM="" D
. . . S LRDFN=0
. . . F S LRDFN=$O(^LRO(69,LRLDT,1,"AR",LRLLOC,PNM,LRDFN)) Q:'LRDFN I LRLDT>$P($G(^LAC("LRAC",LRDFN,0)),U,2) S $P(^LRO(69,LRDT,1,"AR",LRLLOC,PNM,LRDFN),U,2)=$P(^LRO(69,LRLDT,1,"AR",LRLLOC,PNM,LRDFN),U,2)
S LRLDT=LRDT,$P(^LAB(64.5,1,6),U,1)=LRLDT ; Update last Fileroom run date.
L -^LAB(64.5) ; Release locks.
; Will task those reports that are flagged as separate fileroom.
N ZTIO ; Tasked jobs have ZTIO defined, want ZTLOAD to build from IO* variables.
S LRRPTN=0
F S LRRPTN=$O(^LAB(64.5,1,3,LRRPTN)) Q:'LRRPTN D
. S LRX(0)=$G(^LAB(64.5,1,3,LRRPTN,0)),LRX(.1)=$G(^LAB(64.5,1,3,LRRPTN,.1))
. I $P(LRX(0),U,2)["FILE ROOM",$P(LRX(0),U,3)["FILE ROOM",$P(LRX(.1),U,3) D
. . ; Starting/Ending locations contain "FILE ROOM", flag set to YES for FILEROOM REPORT.
. . S IOP=$P(LRX(.1),U,1) Q:IOP="" S %ZIS="N" D ^%ZIS Q:POP ; Get device characteristics.
. . F I="LRPERM","LRXLR","LRDT","LRLDT","LRYDT","LRBOT","LRRE","LRRPTN" S ZTSAVE(I)=""
. . S ZTRTN="DQ^LRFAC",ZTDTH=$H,ZTDESC="Laboratory Fileroom Cumulative"
. . D ^%ZTLOAD K ZTSK ; Task the job.
. K IOP D ^%ZISC ; Restore device parameters.
G END
;
DQ ; Queued entry point to actually print fileroom reports
S $P(^LAB(64.5,1,3,LRRPTN,0),U,4,8)="" ; Clear previous status for this report.
D ENT^LRAC1
S:$D(ZTQUEUED) ZTREQ="@"
Q
;
CHECK ; Check File 64.5 for proper setup.
N LRRPTN,LRX
S LRERR=0,LRX(0)=$G(^LAB(64.5,1,0)),LRX(6)=$G(^LAB(64.5,1,6))
I '$P(LRX(0),U,4) S LRERR=1_U_"Field #4, FILE ROOM, not set to 'YES'!" Q
I '$P(LRX(6),U,2) S LRERR=2_U_"Field #17, SEPARATE FILE ROOM, not set to 'YES'!" Q
S LRRPTN=0 K LRX
F S LRRPTN=$O(^LAB(64.5,1,3,LRRPTN)) Q:LRRPTN<1!(LRERR) D
. S LRX(0)=$G(^LAB(64.5,1,3,LRRPTN,0)),LRX(.1)=$G(^LAB(64.5,1,3,LRRPTN,.1))
. I '$P(LRX(.1),U,3) Q
. I $P(LRX(0),U,2)'["FILE ROOM" S LRERR=3 Q
. I $P(LRX(0),U,3)'["FILE ROOM" S LRERR=4 Q
. S LRRP(LRRPTN)=LRX(0)
I LRERR S LRERR=LRERR_U_"Report: "_$P(LRX(0),U)_" - "_$S(LRERR=3:"Starting",1:"Ending")_" Location does NOT contain 'FILE ROOM'!" Q
I '$D(LRRP) S LRERR=5_U_"No reports for FILE ROOM found!"
Q
;
END ; Clean up time.
S:$D(ZTQUEUED) ZTREQ="@" D ^%ZISC
K %DT,%H,%ZIS,DA,DIR,DIRUT,I,PNM,X,X1,X2,Y,Z
K LRBOT,LRCVT,LRDFN,LRDT,LREND,LRERR,LRLDT,LRLLOC,LRNM,LRPERM,LRRP,LRRPTN,LRRE,LRX,LRXLR,LRYDT,CNT
K XQ1,XQAMSG,XQXFLG
Q
ALERT ;Send Alert Messages to LRLIASON mail group
Q:'$L($G(XQAMSG)) N Y S Y=0 F S Y=$O(^XUSEC("LRLIASON",Y)) S XQA(Y)=""
I $D(XQA) D SETUP^XQALERT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRFAC 4702 printed Sep 23, 2025@19:50:25 Page 2
LRFAC ;MILW/JMC/DALISC/FHS - CUM PRINT FOR FILEROOM PATIENTS TO SEPARATE PRINTER
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
EN ; Entry point from menu option to manually task file room cumulative.
+1 WRITE @IOF,!!?20,"Checking File #64.5, LAB REPORTS FILE"
+2 DO CHECK
IF LRERR
WRITE !!,$CHAR(7),$PIECE(LRERR,U,2),!!
GOTO END
+3 WRITE !,"File Setup ...OK",!!,"Will schedule report(s):"
+4 SET LRRPTN=0
+5 FOR
SET LRRPTN=$ORDER(LRRP(LRRPTN))
if 'LRRPTN
QUIT
WRITE ?25,$PIECE(LRRP(LRRPTN),U),!
+6 KILL DIR
+7 SET DIR(0)="YO"
SET DIR("A")="Print Cumulative for FILE ROOM"
SET DIR("B")="NO"
+8 SET DIR("?")="Answer 'YES' if you want to task the FILE ROOM Cumulative to start."
+9 DO ^DIR
KILL DIR
+10 IF Y
Begin DoDot:1
+11 SET ZTRTN="CLOCK^LRFAC"
SET ZTIO=""
SET ZTDESC="Start FILE ROOM Cumulative"
+12 DO ^%ZTLOAD
WRITE !,"Request ",$SELECT($DATA(ZTSK):"",1:"NOT "),"Queued"
if $DATA(ZTSK)
WRITE !,"Task #",ZTSK
End DoDot:1
+13 GOTO END
+14 ;
CLOCK ; Task fileroom patients cumulative to appropiate devices.
+1 DO CHECK
IF LRERR
Begin DoDot:1
+2 SET XQAMSG="File setup problem observed when attempting to run Lab File Room Cumulative"
+3 DO ALERT
End DoDot:1
GOTO END
+4 KILL ^LAC($JOB),XQAMSG
+5 if '$DATA(^LAB(64.5,1,3))!($DATA(^LAC("LRAC","A")))
QUIT
+6 ; Lock LAB REPORTS file.
SET CNT=0
FOR
LOCK +^LAB(64.5):1
if $TEST
QUIT
HANG 60
SET CNT=1
IF CNT>5
Begin DoDot:1
+7 SET XQAMSG="Unable to lock Lab Reports file (#64.5) check Lock Table"
+8 DO ALERT
End DoDot:1
QUIT
+9 if $DATA(XQAMSG)
GOTO END
+10 ; Get last cumulative report date.
SET LRDT=$PIECE(^LAB(64.5,1,0),U,3)
+11 ;Find last fileroom report date ( if none, set to last report date).
SET LRLDT=$PIECE($GET(^LAB(64.5,1,6)),U,1)
IF 'LRLDT
SET LRLDT=LRDT
+12 SET LRRE=0
SET LRXLR="LRAC"
SET LRPERM=0
SET LRBOT=$PIECE(^LAB(64.5,1,0),U,2)
+13 SET %DT=""
SET X="T"
DO ^%DT
SET LRYDT=Y
+14 ; For each day since last fileroom run, move fileroom patients to current fileroom list.
+15 ; Start with last file room run date in case last run was incomplete.
+16 ; If patient has been printed subsequently - date stored in second piece of ^LAC("LRAC",LRDFN,0) is more recent, then skip.
+17 SET LRLDT=LRLDT-.1
+18 FOR
SET LRLDT=$ORDER(^LRO(69,LRLDT))
if 'LRLDT!(LRLDT'<LRDT)
QUIT
Begin DoDot:1
+19 ; Start with locations containing "FILE ROOM", end when doesn't contain "FILE ROOM".
SET LRLLOC="FILE ROOM"
+20 FOR
SET LRLLOC=$ORDER(^LRO(69,LRLDT,1,"AR",LRLLOC))
if LRLLOC=""!(LRLLOC'["FILE ROOM")
QUIT
Begin DoDot:2
+21 SET PNM=""
+22 FOR
SET PNM=$ORDER(^LRO(69,LRLDT,1,"AR",LRLLOC,PNM))
if PNM=""
QUIT
Begin DoDot:3
+23 SET LRDFN=0
+24 FOR
SET LRDFN=$ORDER(^LRO(69,LRLDT,1,"AR",LRLLOC,PNM,LRDFN))
if 'LRDFN
QUIT
IF LRLDT>$PIECE($GET(^LAC("LRAC",LRDFN,0)),U,2)
SET $PIECE(^LRO(69,LRDT,1,"AR",LRLLOC,PNM,LRDFN),U,2)=$PIECE(^LRO(69,LRLDT,1,"AR",LRLLOC,PNM,LRDFN),U,2)
End DoDot:3
End DoDot:2
End DoDot:1
+25 ; Update last Fileroom run date.
SET LRLDT=LRDT
SET $PIECE(^LAB(64.5,1,6),U,1)=LRLDT
+26 ; Release locks.
LOCK -^LAB(64.5)
+27 ; Will task those reports that are flagged as separate fileroom.
+28 ; Tasked jobs have ZTIO defined, want ZTLOAD to build from IO* variables.
NEW ZTIO
+29 SET LRRPTN=0
+30 FOR
SET LRRPTN=$ORDER(^LAB(64.5,1,3,LRRPTN))
if 'LRRPTN
QUIT
Begin DoDot:1
+31 SET LRX(0)=$GET(^LAB(64.5,1,3,LRRPTN,0))
SET LRX(.1)=$GET(^LAB(64.5,1,3,LRRPTN,.1))
+32 IF $PIECE(LRX(0),U,2)["FILE ROOM"
IF $PIECE(LRX(0),U,3)["FILE ROOM"
IF $PIECE(LRX(.1),U,3)
Begin DoDot:2
+33 ; Starting/Ending locations contain "FILE ROOM", flag set to YES for FILEROOM REPORT.
+34 ; Get device characteristics.
SET IOP=$PIECE(LRX(.1),U,1)
if IOP=""
QUIT
SET %ZIS="N"
DO ^%ZIS
if POP
QUIT
+35 FOR I="LRPERM","LRXLR","LRDT","LRLDT","LRYDT","LRBOT","LRRE","LRRPTN"
SET ZTSAVE(I)=""
+36 SET ZTRTN="DQ^LRFAC"
SET ZTDTH=$HOROLOG
SET ZTDESC="Laboratory Fileroom Cumulative"
+37 ; Task the job.
DO ^%ZTLOAD
KILL ZTSK
End DoDot:2
+38 ; Restore device parameters.
KILL IOP
DO ^%ZISC
End DoDot:1
+39 GOTO END
+40 ;
DQ ; Queued entry point to actually print fileroom reports
+1 ; Clear previous status for this report.
SET $PIECE(^LAB(64.5,1,3,LRRPTN,0),U,4,8)=""
+2 DO ENT^LRAC1
+3 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
+5 ;
CHECK ; Check File 64.5 for proper setup.
+1 NEW LRRPTN,LRX
+2 SET LRERR=0
SET LRX(0)=$GET(^LAB(64.5,1,0))
SET LRX(6)=$GET(^LAB(64.5,1,6))
+3 IF '$PIECE(LRX(0),U,4)
SET LRERR=1_U_"Field #4, FILE ROOM, not set to 'YES'!"
QUIT
+4 IF '$PIECE(LRX(6),U,2)
SET LRERR=2_U_"Field #17, SEPARATE FILE ROOM, not set to 'YES'!"
QUIT
+5 SET LRRPTN=0
KILL LRX
+6 FOR
SET LRRPTN=$ORDER(^LAB(64.5,1,3,LRRPTN))
if LRRPTN<1!(LRERR)
QUIT
Begin DoDot:1
+7 SET LRX(0)=$GET(^LAB(64.5,1,3,LRRPTN,0))
SET LRX(.1)=$GET(^LAB(64.5,1,3,LRRPTN,.1))
+8 IF '$PIECE(LRX(.1),U,3)
QUIT
+9 IF $PIECE(LRX(0),U,2)'["FILE ROOM"
SET LRERR=3
QUIT
+10 IF $PIECE(LRX(0),U,3)'["FILE ROOM"
SET LRERR=4
QUIT
+11 SET LRRP(LRRPTN)=LRX(0)
End DoDot:1
+12 IF LRERR
SET LRERR=LRERR_U_"Report: "_$PIECE(LRX(0),U)_" - "_$SELECT(LRERR=3:"Starting",1:"Ending")_" Location does NOT contain 'FILE ROOM'!"
QUIT
+13 IF '$DATA(LRRP)
SET LRERR=5_U_"No reports for FILE ROOM found!"
+14 QUIT
+15 ;
END ; Clean up time.
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
DO ^%ZISC
+2 KILL %DT,%H,%ZIS,DA,DIR,DIRUT,I,PNM,X,X1,X2,Y,Z
+3 KILL LRBOT,LRCVT,LRDFN,LRDT,LREND,LRERR,LRLDT,LRLLOC,LRNM,LRPERM,LRRP,LRRPTN,LRRE,LRX,LRXLR,LRYDT,CNT
+4 KILL XQ1,XQAMSG,XQXFLG
+5 QUIT
ALERT ;Send Alert Messages to LRLIASON mail group
+1 if '$LENGTH($GET(XQAMSG))
QUIT
NEW Y
SET Y=0
FOR
SET Y=$ORDER(^XUSEC("LRLIASON",Y))
SET XQA(Y)=""
+2 IF $DATA(XQA)
DO SETUP^XQALERT
+3 QUIT
