LRPHSET ; IHS/DIR/FJE - COLLECTION LIST TO ACCESSIONS ; 05-JAN-2015 12:24 ; MAW
;;5.2;LAB SERVICE;**1026,1034,1036,1039**;NOV 1, 1997;Build 38
;
;;5.2;LAB SERVICE;;Sep 27, 1994
;K LRPARAM D ^LRPARAM Q:'$D(LRPARAM)
S:$G(BLROPT)=""!($G(BLROPT(0))'=$P(XQY0,U)) BLROPT="ADDCOL",BLROPT(0)=$P(XQY0,U) K LRPARAM D ^LRPARAM Q:'$D(LRPARAM) ;IHS/OIRM TUC/AAB 2/1/97
S:$D(ZTQUEUED) LRLABLTF=1,LRTE=1 S LREND=0 D:$P(^LAB(69.9,1,"RO"),U,2)!($P(^("RO"),U))<$P($H,",") ROLL G:LREND=1 END1 D NOW G END1:'$D(LRDTI) G MANUAL:'$D(ZTQUEUED) G NEW:$D(ZTQUEUED)
NEW G RUNING:$P(^LAB(69.9,1,5),"^",10) K ^LRO(69.1,1),^("B"),^("LRPH") S ^LRO(69.1,1,0)=1_"^"_DT_"^"_$P(LRDTI,".",2),^LRO(69.1,"B",1,1)="",$P(^LRO(69.1,0),"^",3,4)=1_"^"_1,LRTE=1,$P(^LAB(69.9,1,5),"^",14,15)=LRDTI_"^"
ADD S LRPHSET=1,LRODT=DT I '$D(ZTQUEUED) W !,"BUILDING THE LIST"
S TIME=$P($H,",",2) D EN^LRPHSET1 S TIME1=$P($H,",",2),TIME3=TIME1-TIME
I '$P($G(^BLRSITE($S($G(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,22) D BLRRL(.BLRORDLC) ;ihs/cmi/maw 12/30/2014 p1034
G END
MANUAL ;ENTRY POINT
S LRTE=1 G RUNING:$P(^LAB(69.9,1,5),"^",10) I '$D(^LRO(69.1,LRTE,0)) S ^(0)=1_"^"_DT_"^"_$P(LRDTI,".",2)
I $O(^LRO(69.1,LRTE,1,0))'="" S LROCT=$P(^LRO(69.1,1,0),U,2)_"."_$P(^LRO(69.1,1,0),U,3) I LROCT<LRDTI S Y=LROCT D DD^LRX W !,"The collection list for ",Y," still exists, you must clear it before ",!,"building a new list." G B
I $O(^LRO(69.1,LRTE,1,0))'="" W !,"There is some data in the current collection list." I $D(^LRO(69.1,LRTE,0))#2,$L($P(^LRO(69.1,LRTE,0),U,2)) S Y=$P(^(0),U,2) D DD^LRX W !,"Labels last printed on ",Y,!
A S %=2 I $S('$D(^LRO(69.1,1,0))#2:1,$P(^(0),U,2)'<DT:1,1:0) F I=0:0 W !,"Do you wish to add entries.) " S %=1 D YN^DICN Q:% W !,"Your wish is my command. Please enter Yes or No."
G END1:%<0,ADD:%=1
B F I=0:0 W !,"Are you ready to clear the current collection list",!,"and start a new one" S %=2 D YN^DICN Q:% W !,"Answer 'Y'es or 'N'o."
G NEW:%=1,END1
END K LRPHSET,LRTJ,LRDUZ S:$D(ZTQUEUED) ZTREQ="@"
I '$D(ZTQUEUED) W !,+LRCOUNT," specimens added to collection list."
D ^LRPHLIST D ^%ZISC
END1 K DIC,LRPHSET,LRTJ,LRDUZ,%DT,%H,%ZA,%ZB,%ZC,DA,DO,I2,I5,LABEL,LRBED,LRCCOM,LRCS,LRCSN,LRCSS,LREXP,LRFIN,LRFLOG,LRGCOM,LRIOZERO,LRLABLTF,LRLBLD,LRLWC,LRM,LRNCWL,LRNIDT,LRNOLABL,LROCN,LROID,LROLRDFN,LRORDER,LRORDR,LRORDTIM,LROSN,LROT,LROUTINE
K BLRORDLC,BLRLCLNT,BLROR ;ihs/cmi/maw p1034
K LREND,LRLBL,LRQ,LRSLIP,LRSSX,LRSTA,LRSTIK,LRSUM,LRSXN,LRTOP,LRTP,LRTSTNM,LRUR,LRUSNM,LRWPC,S5,ZTIO,TIME,TIME1,TIME3 Q
NOW K LRDTI I '$D(ZTQUEUED) S %DT("A")="Date and Time of collection: ",%DT="ETR" D TIME,DATE^LRWU Q:Y<0 I +Y'=DT W !,"Are you sure" S %=2 D YN^DICN I %'=1 W:%=0 !,"The date should be today's date." G NOW:%=0 Q
I $D(ZTQUEUED) S %DT="T" D TIME S X=%DT("B") D ^%DT
S LRDTI=Y Q
TIME S Y=$O(^LAB(69.9,1,4,"AC",$P($H,",",2))),Y=$S(Y>0:$O(^(Y,0)),1:Y) I Y'>0 S %DT("B")="NOW" Q
S Y=$P(^LAB(69.9,1,4,Y,0),U,2)
S Z=$S(+$E(Y,1,2)>11:"PM",1:"AM"),Y=$E(Y_0,1,2)-$S($E(Y_0,1,2)=12:0,Z="PM":12,1:0)_":"_$E(Y_"000",3,4)_Z
S %DT("B")="T@"_Y
Q
BLRRL(BLROR) ; Do the shipping manifest and message here
;ihs/cmi/maw 12/30/2014 p1034
N BLRA
S BLRA=0 F S BLRA=$O(BLROR(BLRA)) Q:'BLRA D
. D SHIPMAN^BLRRLEVN(BLRA,0,0) ;p1034
Q
;
RUNING W:'$D(ZTQUEUED) !!,"ALREADY RUNNING.",!! Q
ROLL ;ROLLOVER NOT FINISHED OR NOT RUN...BLOCKS COLLECTION LIST
; W @IOF S X="N",%DT="ET" D ^%DT
; ----- BEGIN IHS/OIT/MKK - Modification LR*5.2*1026
W @$S($G(IOF)'="":IOF,1:"!!!")
S X="N",%DT="ET" D ^%DT
; ----- END IHS/OIT/MKK - Modification LR*5.2*1026
I $P(^LAB(69.9,1,"RO"),U,2)>0 W:'$D(ZTQUEUED) !,"CAN'T BUILD COLLECTION LIST WHILE ROLLOVER IS STILL RUNNING!",!,"Contact IRM for the reason ROLLOVER is still running, then manually build the collection list." S LREND=1 Q
I $P(^LAB(69.9,1,"RO"),U)<$P($H,",") W:'$D(ZTQUEUED) !,"I NEED TO RUN ROLLOVER BEFORE BUILDING THE COLLECTION LIST!",!,"After ROLLOVER completes, I will build the collection list." D ^LROLOVER Q
LRPHSET ; IHS/DIR/FJE - COLLECTION LIST TO ACCESSIONS ; 05-JAN-2015 12:24 ; MAW
+1 ;;5.2;LAB SERVICE;**1026,1034,1036,1039**;NOV 1, 1997;Build 38
+2 ;
+3 ;;5.2;LAB SERVICE;;Sep 27, 1994
+4 ;K LRPARAM D ^LRPARAM Q:'$D(LRPARAM)
+5 ;IHS/OIRM TUC/AAB 2/1/97
IF $GET(BLROPT)=""!($GET(BLROPT(0))'=$PIECE(XQY0,U))
SET BLROPT="ADDCOL"
SET BLROPT(0)=$PIECE(XQY0,U)
KILL LRPARAM
DO ^LRPARAM
IF '$DATA(LRPARAM)
QUIT
+6 IF $DATA(ZTQUEUED)
SET LRLABLTF=1
SET LRTE=1
SET LREND=0
IF $PIECE(^LAB(69.9,1,"RO"),U,2)!($PIECE(^("RO"),U))<$PIECE($HOROLOG,",")
DO ROLL
IF LREND=1
GOTO END1
DO NOW
IF '$DATA(LRDTI)
GOTO END1
IF '$DATA(ZTQUEUED)
GOTO MANUAL
IF $DATA(ZTQUEUED)
GOTO NEW
NEW IF $PIECE(^LAB(69.9,1,5),"^",10)
GOTO RUNING
KILL ^LRO(69.1,1),^("B"),^("LRPH")
SET ^LRO(69.1,1,0)=1_"^"_DT_"^"_$PIECE(LRDTI,".",2)
SET ^LRO(69.1,"B",1,1)=""
SET $PIECE(^LRO(69.1,0),"^",3,4)=1_"^"_1
SET LRTE=1
SET $PIECE(^LAB(69.9,1,5),"^",14,15)=LRDTI_"^"
ADD SET LRPHSET=1
SET LRODT=DT
IF '$DATA(ZTQUEUED)
WRITE !,"BUILDING THE LIST"
+1 SET TIME=$PIECE($HOROLOG,",",2)
DO EN^LRPHSET1
SET TIME1=$PIECE($HOROLOG,",",2)
SET TIME3=TIME1-TIME
+2 ;ihs/cmi/maw 12/30/2014 p1034
IF '$PIECE($GET(^BLRSITE($SELECT($GET(BLRALTDZ):BLRALTDZ,1:DUZ(2)),"RL")),U,22)
DO BLRRL(.BLRORDLC)
+3 GOTO END
MANUAL ;ENTRY POINT
+1 SET LRTE=1
IF $PIECE(^LAB(69.9,1,5),"^",10)
GOTO RUNING
IF '$DATA(^LRO(69.1,LRTE,0))
SET ^(0)=1_"^"_DT_"^"_$PIECE(LRDTI,".",2)
+2 IF $ORDER(^LRO(69.1,LRTE,1,0))'=""
SET LROCT=$PIECE(^LRO(69.1,1,0),U,2)_"."_$PIECE(^LRO(69.1,1,0),U,3)
IF LROCT<LRDTI
SET Y=LROCT
DO DD^LRX
WRITE !,"The collection list for ",Y," still exists, you must clear it before ",!,"building a new list."
GOTO B
+3 IF $ORDER(^LRO(69.1,LRTE,1,0))'=""
WRITE !,"There is some data in the current collection list."
IF $DATA(^LRO(69.1,LRTE,0))#2
IF $LENGTH($PIECE(^LRO(69.1,LRTE,0),U,2))
SET Y=$PIECE(^(0),U,2)
DO DD^LRX
WRITE !,"Labels last printed on ",Y,!
A SET %=2
IF $SELECT('$DATA(^LRO(69.1,1,0))#2:1,$PIECE(^(0),U,2)'<DT:1,1:0)
FOR I=0:0
WRITE !,"Do you wish to add entries.) "
SET %=1
DO YN^DICN
IF %
QUIT
WRITE !,"Your wish is my command. Please enter Yes or No."
+1 IF %<0
GOTO END1
IF %=1
GOTO ADD
B FOR I=0:0
WRITE !,"Are you ready to clear the current collection list",!,"and start a new one"
SET %=2
DO YN^DICN
IF %
QUIT
WRITE !,"Answer 'Y'es or 'N'o."
+1 IF %=1
GOTO NEW
GOTO END1
END KILL LRPHSET,LRTJ,LRDUZ
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 IF '$DATA(ZTQUEUED)
WRITE !,+LRCOUNT," specimens added to collection list."
+2 DO ^LRPHLIST
DO ^%ZISC
END1 KILL DIC,LRPHSET,LRTJ,LRDUZ,%DT,%H,%ZA,%ZB,%ZC,DA,DO,I2,I5,LABEL,LRBED,LRCCOM,LRCS,LRCSN,LRCSS,LREXP,LRFIN,LRFLOG,LRGCOM,LRIOZERO,LRLABLTF,LRLBLD,LRLWC,LRM,LRNCWL,LRNIDT,LRNOLABL,LROCN,LROID,LROLRDFN,LRORDER,LRORDR,LRORDTIM,LROSN,LROT,LROUTINE
+1 ;ihs/cmi/maw p1034
KILL BLRORDLC,BLRLCLNT,BLROR
+2 KILL LREND,LRLBL,LRQ,LRSLIP,LRSSX,LRSTA,LRSTIK,LRSUM,LRSXN,LRTOP,LRTP,LRTSTNM,LRUR,LRUSNM,LRWPC,S5,ZTIO,TIME,TIME1,TIME3
QUIT
NOW KILL LRDTI
IF '$DATA(ZTQUEUED)
SET %DT("A")="Date and Time of collection: "
SET %DT="ETR"
DO TIME
DO DATE^LRWU
IF Y<0
QUIT
IF +Y'=DT
WRITE !,"Are you sure"
SET %=2
DO YN^DICN
IF %'=1
IF %=0
WRITE !,"The date should be today's date."
IF %=0
GOTO NOW
QUIT
+1 IF $DATA(ZTQUEUED)
SET %DT="T"
DO TIME
SET X=%DT("B")
DO ^%DT
+2 SET LRDTI=Y
QUIT
TIME SET Y=$ORDER(^LAB(69.9,1,4,"AC",$PIECE($HOROLOG,",",2)))
SET Y=$SELECT(Y>0:$ORDER(^(Y,0)),1:Y)
IF Y'>0
SET %DT("B")="NOW"
QUIT
+1 SET Y=$PIECE(^LAB(69.9,1,4,Y,0),U,2)
+2 SET Z=$SELECT(+$EXTRACT(Y,1,2)>11:"PM",1:"AM")
SET Y=$EXTRACT(Y_0,1,2)-$SELECT($EXTRACT(Y_0,1,2)=12:0,Z="PM":12,1:0)_":"_$EXTRACT(Y_"000",3,4)_Z
+3 SET %DT("B")="T@"_Y
+4 QUIT
BLRRL(BLROR) ; Do the shipping manifest and message here
+1 ;ihs/cmi/maw 12/30/2014 p1034
+2 NEW BLRA
+3 SET BLRA=0
FOR
SET BLRA=$ORDER(BLROR(BLRA))
IF 'BLRA
QUIT
Begin DoDot:1
+4 ;p1034
DO SHIPMAN^BLRRLEVN(BLRA,0,0)
End DoDot:1
+5 QUIT
+6 ;
RUNING IF '$DATA(ZTQUEUED)
WRITE !!,"ALREADY RUNNING.",!!
QUIT
ROLL ;ROLLOVER NOT FINISHED OR NOT RUN...BLOCKS COLLECTION LIST
+1 ; W @IOF S X="N",%DT="ET" D ^%DT
+2 ; ----- BEGIN IHS/OIT/MKK - Modification LR*5.2*1026
+3 WRITE @$SELECT($GET(IOF)'="":IOF,1:"!!!")
+4 SET X="N"
SET %DT="ET"
DO ^%DT
+5 ; ----- END IHS/OIT/MKK - Modification LR*5.2*1026
+6 IF $PIECE(^LAB(69.9,1,"RO"),U,2)>0
IF '$DATA(ZTQUEUED)
WRITE !,"CAN'T BUILD COLLECTION LIST WHILE ROLLOVER IS STILL RUNNING!",!,"Contact IRM for the reason ROLLOVER is still running, then manually build the collection list."
SET LREND=1
QUIT
+7 IF $PIECE(^LAB(69.9,1,"RO"),U)<$PIECE($HOROLOG,",")
IF '$DATA(ZTQUEUED)
WRITE !,"I NEED TO RUN ROLLOVER BEFORE BUILDING THE COLLECTION LIST!",!,"After ROLLOVER completes, I will build the collection list."
DO ^LROLOVER
QUIT
