LRACFR ;MILW/JMC- Lab cumulative print fileroom patients ;2/20/91 08:33 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
EN ; Entry point from menu option to manually task file room cumulative.
W @IOF,"Checking File #64.5, LAB REPORTS FILE"
D CHECK I LRERR W !!,$C(7),$P(LRERR,U,2),!! G END
W " ...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^LRACFR",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"
. K XQA S Y=0 F S Y=$O(^XUSEC("LRLIASON",Y)) Q:Y="" S XQA(Y)=""
. I $D(XQA) D SETUP^XQALERT
K ^LAC($J)
Q:'$D(^LAB(64.5,1,3))!($D(^LAC("LRAC","A")))
L +^LAB(64.5) ; Lock LAB REPORTS file.
S LRLDT=$P($G(^LAB(64.5,1,6)),U,1),LRDT=$P(^LAB(64.5,1,0),U,3) I 'LRLDT S LRLDT=LRDT ;Find last fileroom report date ( if none, set to last report date).
L -^LAB(64.5) ; Release locks.
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.
; If patient has been printed subsequently - date stored in second piece of ^LAC("LRAC",LRDFN,0) is more recent, then skip.
S X1=LRDT,X2=LRLDT D ^%DTC
I X>1 D
. S LRCVT=X-1
. F I=1:1:LRCVT S X=LRLDT D H^%DTC S %H=%H+1 D YMD^%DTC S LRLDT=X D
. . S LRLLOC="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)
; 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<1 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 SEPARATE FILEROOM (field #17 in file #64.5).
. . 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^LRACFR",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 LRFRDT=LRDT,$P(^LAB(64.5,1,3,LRRPTN,0),U,4,8)="" ; Clear previous status for this report.
D ENT^LRAC1
S $P(^LAB(64.5,1,6),U,1)=LRFRDT ; Update last Fileroom run date.
S:$D(ZTQUEUED) ZTREQ="@"
K LRFRDT
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(LREND=1:"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="@"
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRACFR 4323 printed Nov 22, 2024@17:16:24 Page 2
LRACFR ;MILW/JMC- Lab cumulative print fileroom patients ;2/20/91 08:33 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
EN ; Entry point from menu option to manually task file room cumulative.
+1 WRITE @IOF,"Checking File #64.5, LAB REPORTS FILE"
+2 DO CHECK
IF LRERR
WRITE !!,$CHAR(7),$PIECE(LRERR,U,2),!!
GOTO END
+3 WRITE " ...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^LRACFR"
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 KILL XQA
SET Y=0
FOR
SET Y=$ORDER(^XUSEC("LRLIASON",Y))
if Y=""
QUIT
SET XQA(Y)=""
+4 IF $DATA(XQA)
DO SETUP^XQALERT
End DoDot:1
GOTO END
+5 KILL ^LAC($JOB)
+6 if '$DATA(^LAB(64.5,1,3))!($DATA(^LAC("LRAC","A")))
QUIT
+7 ; Lock LAB REPORTS file.
LOCK +^LAB(64.5)
+8 ;Find last fileroom report date ( if none, set to last report date).
SET LRLDT=$PIECE($GET(^LAB(64.5,1,6)),U,1)
SET LRDT=$PIECE(^LAB(64.5,1,0),U,3)
IF 'LRLDT
SET LRLDT=LRDT
+9 ; Release locks.
LOCK -^LAB(64.5)
+10 SET LRRE=0
SET LRXLR="LRAC"
SET LRPERM=0
SET LRBOT=$PIECE(^LAB(64.5,1,0),U,2)
+11 SET %DT=""
SET X="T"
DO ^%DT
SET LRYDT=Y
+12 ; For each day since last fileroom run, move fileroom patients to current fileroom list.
+13 ; If patient has been printed subsequently - date stored in second piece of ^LAC("LRAC",LRDFN,0) is more recent, then skip.
+14 SET X1=LRDT
SET X2=LRLDT
DO ^%DTC
+15 IF X>1
Begin DoDot:1
+16 SET LRCVT=X-1
+17 FOR I=1:1:LRCVT
SET X=LRLDT
DO H^%DTC
SET %H=%H+1
DO YMD^%DTC
SET LRLDT=X
Begin DoDot:2
+18 SET LRLLOC="FILE ROOM"
+19 FOR
SET LRLLOC=$ORDER(^LRO(69,LRLDT,1,"AR",LRLLOC))
if LRLLOC=""!(LRLLOC'["FILE ROOM")
QUIT
Begin DoDot:3
+20 SET PNM=""
+21 FOR
SET PNM=$ORDER(^LRO(69,LRLDT,1,"AR",LRLLOC,PNM))
if PNM=""
QUIT
Begin DoDot:4
+22 SET LRDFN=0
+23 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:4
End DoDot:3
End DoDot:2
End DoDot:1
+24 ; Will task those reports that are flagged as separate fileroom.
+25 ; Tasked jobs have ZTIO defined, want ZTLOAD to build from IO* variables.
NEW ZTIO
+26 SET LRRPTN=0
+27 FOR
SET LRRPTN=$ORDER(^LAB(64.5,1,3,LRRPTN))
if LRRPTN<1
QUIT
Begin DoDot:1
+28 SET LRX(0)=$GET(^LAB(64.5,1,3,LRRPTN,0))
SET LRX(.1)=$GET(^LAB(64.5,1,3,LRRPTN,.1))
+29 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
+30 ; Starting/Ending locations contain "FILE ROOM", flag set to YES for SEPARATE FILEROOM (field #17 in file #64.5).
+31 ; Get device characteristics.
SET IOP=$PIECE(LRX(.1),U,1)
if IOP=""
QUIT
SET %ZIS="N"
DO ^%ZIS
if POP
QUIT
+32 FOR I="LRPERM","LRXLR","LRDT","LRLDT","LRYDT","LRBOT","LRRE","LRRPTN"
SET ZTSAVE(I)=""
+33 SET ZTRTN="DQ^LRACFR"
SET ZTDTH=$HOROLOG
SET ZTDESC="Laboratory Fileroom Cumulative"
+34 ; Task the job.
DO ^%ZTLOAD
KILL ZTSK
End DoDot:2
+35 ; Restore device parameters.
KILL IOP
DO ^%ZISC
End DoDot:1
+36 GOTO END
+37 ;
DQ ; Queued entry point to actually print fileroom reports
+1 ; Clear previous status for this report.
SET LRFRDT=LRDT
SET $PIECE(^LAB(64.5,1,3,LRRPTN,0),U,4,8)=""
+2 DO ENT^LRAC1
+3 ; Update last Fileroom run date.
SET $PIECE(^LAB(64.5,1,6),U,1)=LRFRDT
+4 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 KILL LRFRDT
+6 QUIT
+7 ;
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(LREND=1:"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="@"
+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
+4 QUIT
