- LRPHEXPT ;SLC/CJS/RWF-EXCEPTION LOGIN OF ACCESSIONS ;8/11/97 [ 04/14/2003 12:01 PM ]
- ;;5.2T9;LR;**1001,1003,1018**;Nov 17, 2004
- ;;5.2;LAB SERVICE;**43,121,221**;Sep 27, 1994
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- S:$G(BLROPT)=""!($G(BLROPT(0))'=$P(XQY0,U)) BLROPT="RECCOL",BLROPT(0)=$P(XQY0,U) ;IHS/DIR TUC/AAB 04/17/98
- ;----- END IHS MODIFICATIONS
- S X="N",%DT="T" D ^%DT S LRODT=DT,LRNT=Y
- LR1 ;
- D ^LRPARAM QUIT:$G(LREND) ;-> 4/25/95 LJA
- ;
- D FNDLOC^LRDRAW G END:LRLLOC["^" I LRLLOC=""&'$D(^XUSEC("LRPHSUPER",DUZ)) W !,"You don't have the LRPHSUPER key to enter 'ALL'." G LRPHEXPT
- I LRLLOC="" W !,"You're doing the entire collection" S %=2 D YN^DICN W:%=0 !,"Maybe you'd better think about it some more." G END:%'=1
- K LRSN,LROR,LRCOM,LRTCOM,LRNOCOM W !,"Enter Order Numbers not collected: "
- LOOP S LRFIRST=1,LROR=0 D
- . D LP1^LRPHITEM
- I $O(LROR(0))>0 W !,"Let's handle the exceptions first.",! D
- . N LRLLOC,LRODT
- . S LROR=0 F S LROR=$O(LROR(LROR)) Q:LROR<1 D EXCEPT^LRPHITE3 W ! D EQUALS^LRX W !
- W !!,"Now enter any orders that are not canceled but you don't want ""collected"", yet.",!,"If all remaining orders are collected, skip this entry."
- W !,"Any order #'s entered here will remain on collection list until 12 midnight.",!,"The orders will not 'rollover' to the next days collection list."
- K LROR S LROR=0,LRNOCOM=1 D
- . D LP1^LRPHITEM
- S %=2 W !!,"Ready to accept the rest of the orders" D YN^DICN G END:%'=1
- D INV G:LRLLOC'="" E1 S LRLLOC="" F S LRLLOC=$O(^LRO(69,LRODT,1,"AC",LRLLOC)) Q:LRLLOC="" D E2
- G LR1
- Q
- E1 D E2 G LR1
- E2 S LRSN=0 F S LRSN=$O(^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)) Q:LRSN="" D
- . I ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=1 I $S($D(^LRO(69,LRODT,1,LRSN,.1)):'$D(LROR(^(.1))),1:1) D P15^LRPHITEM W:$P(^LRO(69,LRODT,1,LRSN,1),U,4)="C" !,LRLLOC," ",$S($D(^(.1)):^(.1),1:".")
- Q
- INV K ^TMP($J) S %X="LROR(",%Y="^TMP($J," D %XY^%RCR K LROR F I=1:1 Q:'$D(^TMP($J,I)) S LROR(^(I))=""
- Q
- % R %:DTIME Q:%=""!(%["N")!(%["Y") W !,"Answer 'Y' or 'N': " G %
- END K %,A,J1,K,LRFIRST,LRFORD,LRLLOC,LRNOCOM,LRNT,LRODT,LROR,LRSN,X,Y,Z,DIC,LRLLOC,LRAA,LRAD,LRAN,LRDFN,LRSS,LRIDT,LROID,T,LRSN,I,%H,%X,%Y,DIWL,DIWR,DO,DPF,LRBED,LRCS,LRCSN,LRCSS,LRDC,LRDTO,LRFLOG,LRIOZERO,LRIX,LRLWC,LRM,LRORDR,LRORDTIM
- K LRGCOM,LROUTINE,LRPR,LRRND,LRSSX,LRSTIK,LRTSN,LRUNQ,LRUR,LRWD,LRWPC,POP Q
- LRPHEXPT ;SLC/CJS/RWF-EXCEPTION LOGIN OF ACCESSIONS ;8/11/97 [ 04/14/2003 12:01 PM ]
- +1 ;;5.2T9;LR;**1001,1003,1018**;Nov 17, 2004
- +2 ;;5.2;LAB SERVICE;**43,121,221**;Sep 27, 1994
- +3 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +4 ;IHS/DIR TUC/AAB 04/17/98
- IF $GET(BLROPT)=""!($GET(BLROPT(0))'=$PIECE(XQY0,U))
- SET BLROPT="RECCOL"
- SET BLROPT(0)=$PIECE(XQY0,U)
- +5 ;----- END IHS MODIFICATIONS
- +6 SET X="N"
- SET %DT="T"
- DO ^%DT
- SET LRODT=DT
- SET LRNT=Y
- LR1 ;
- +1 ;-> 4/25/95 LJA
- DO ^LRPARAM
- IF $GET(LREND)
- QUIT
- +2 ;
- +3 DO FNDLOC^LRDRAW
- IF LRLLOC["^"
- GOTO END
- IF LRLLOC=""&'$DATA(^XUSEC("LRPHSUPER",DUZ))
- WRITE !,"You don't have the LRPHSUPER key to enter 'ALL'."
- GOTO LRPHEXPT
- +4 IF LRLLOC=""
- WRITE !,"You're doing the entire collection"
- SET %=2
- DO YN^DICN
- IF %=0
- WRITE !,"Maybe you'd better think about it some more."
- IF %'=1
- GOTO END
- +5 KILL LRSN,LROR,LRCOM,LRTCOM,LRNOCOM
- WRITE !,"Enter Order Numbers not collected: "
- LOOP SET LRFIRST=1
- SET LROR=0
- Begin DoDot:1
- +1 DO LP1^LRPHITEM
- End DoDot:1
- +2 IF $ORDER(LROR(0))>0
- WRITE !,"Let's handle the exceptions first.",!
- Begin DoDot:1
- +3 NEW LRLLOC,LRODT
- +4 SET LROR=0
- FOR
- SET LROR=$ORDER(LROR(LROR))
- IF LROR<1
- QUIT
- DO EXCEPT^LRPHITE3
- WRITE !
- DO EQUALS^LRX
- WRITE !
- End DoDot:1
- +5 WRITE !!,"Now enter any orders that are not canceled but you don't want ""collected"", yet.",!,"If all remaining orders are collected, skip this entry."
- +6 WRITE !,"Any order #'s entered here will remain on collection list until 12 midnight.",!,"The orders will not 'rollover' to the next days collection list."
- +7 KILL LROR
- SET LROR=0
- SET LRNOCOM=1
- Begin DoDot:1
- +8 DO LP1^LRPHITEM
- End DoDot:1
- +9 SET %=2
- WRITE !!,"Ready to accept the rest of the orders"
- DO YN^DICN
- IF %'=1
- GOTO END
- +10 DO INV
- IF LRLLOC'=""
- GOTO E1
- SET LRLLOC=""
- FOR
- SET LRLLOC=$ORDER(^LRO(69,LRODT,1,"AC",LRLLOC))
- IF LRLLOC=""
- QUIT
- DO E2
- +11 GOTO LR1
- +12 QUIT
- E1 DO E2
- GOTO LR1
- E2 SET LRSN=0
- FOR
- SET LRSN=$ORDER(^LRO(69,LRODT,1,"AC",LRLLOC,LRSN))
- IF LRSN=""
- QUIT
- Begin DoDot:1
- +1 IF ^LRO(69,LRODT,1,"AC",LRLLOC,LRSN)=1
- IF $SELECT($DATA(^LRO(69,LRODT,1,LRSN,.1)):'$DATA(LROR(^(.1))),1:1)
- DO P15^LRPHITEM
- IF $PIECE(^LRO(69,LRODT,1,LRSN,1),U,4)="C"
- WRITE !,LRLLOC," ",$SELECT($DATA(^(.1)):^(.1),1:".")
- End DoDot:1
- +2 QUIT
- INV KILL ^TMP($JOB)
- SET %X="LROR("
- SET %Y="^TMP($J,"
- DO %XY^%RCR
- KILL LROR
- FOR I=1:1
- IF '$DATA(^TMP($JOB,I))
- QUIT
- SET LROR(^(I))=""
- +1 QUIT
- % READ %:DTIME
- IF %=""!(%["N")!(%["Y")
- QUIT
- WRITE !,"Answer 'Y' or 'N': "
- GOTO %
- END KILL %,A,J1,K,LRFIRST,LRFORD,LRLLOC,LRNOCOM,LRNT,LRODT,LROR,LRSN,X,Y,Z,DIC,LRLLOC,LRAA,LRAD,LRAN,LRDFN,LRSS,LRIDT,LROID,T,LRSN,I,%H,%X,%Y,DIWL,DIWR,DO,DPF,LRBED,LRCS,LRCSN,LRCSS,LRDC,LRDTO,LRFLOG,LRIOZERO,LRIX,LRLWC,LRM,LRORDR,LRORDTIM
- +1 KILL LRGCOM,LROUTINE,LRPR,LRRND,LRSSX,LRSTIK,LRTSN,LRUNQ,LRUR,LRWD,LRWPC,POP
- QUIT
