LRCONJAM ;SLC/CJS,MILW/JMC - JAM CONTROLS ONTO ACCESSION ;2/19/91 10:31 ; 9/20/19 2:55pm
;;5.2;LAB SERVICE;**65,531**;Sep 27, 1994;Build 7
S:$D(ZTQUEUED) ZTREQ="@" S LREND=0,U="^",LRAA=0,LRPARAM="1^"_$P($G(^LAB(69.9,1,0)),U,2,99) D DT^LRX,VIDEO^LRPARAM D L,END Q
L D L1 I LREND K D,DA,LREND,LRSS,LRTEST,LRYR Q
S LRCN=0 F S LRCN=$O(^LRO(68,LRAA,.5,LRCN)) Q:LRCN<1 S LRINC=0 D L2
G L
L2 S LRAN=0 F S LRAN=$O(^LRO(68,LRAA,.5,LRCN,1,LRAN)) Q:LRAN<1 S LRIFN=+^LRO(68,LRAA,.5,LRCN,1,LRAN,0) D LRTST,SETUP L -^LRO(68,LRAA) L -^LRO(69,DT)
Q
SETUP D ORDER Q:LRDFN<1 Q:'LRTCNT
L +^LRO(68,LRAA):1 I $D(^LRO(68,LRAA,1,LRAD,1,LRAN)) L -^LRO(68,LRAA) D FAIL Q
I $D(^LRO(68,LRAA,1,LRAD,0))[0 S ^(0)=LRAD,^(1,0)="^68.02PA^" I $D(^LRO(68,LRAA,1,0))[0 S ^(0)="^68.01DA^"_LRAD_"^"
S ^LRO(68,LRAA,1,LRAD,1,LRAN,0)=LRDFN_"^62.3^"_$P(LRNT,".")_U_DT_U_LRSN,^(3)=LRNT_"^^"_LRNT_"^^"_LRIDT,^(.1)=LRORD
S ^LRO(68,LRAA,1,LRAD,1,"E",LRNT,LRAN)="",^LRO(68,LRAA,1,LRAD,1,"D",LRORD,LRAN)=""
S ^LRO(68,LRAA,1,LRAD,1,LRAN,.2)=$P(^LRO(68,LRAA,0),U,11)_" "_$S(LRAD["0000":$E(LRAD,2,3),1:$E(LRAD,4,7))_" "_LRAN,LRHCT=""
;LR*5.2*531 SET PARENT TEST (#8.1)
F K=1:1:LRTCNT S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST(K),0)=LRTEST(K)_U_LROUTINE,$P(^(0),U,9)=LRTEST(K),^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRTEST(K),LRTEST(K))="" S:LRTEST(K)>LRHCT LRHCT=LRTEST(K) D T
S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)="^68.04PA^"_LRHCT_"^"_LRTCNT
S:LRSPEC ^LRO(68,LRAA,1,LRAD,1,LRAN,5,0)="^68.05PA^1^1",^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)=LRSPEC
S LRUID=$$LRUID^LRX(LRAA,LRAD,LRAN) D EN^LA7ADL(LRUID) ;Creates UID for controls and check for automatic downloading
IF '$D(^LR(LRDFN,LRSS,0)) S ^LR(LRDFN,LRSS,0)=U_$P(^DD(63,$O(^DD(63,"GL",LRSS,0,0)),0),U,2)_U
S ^LR(LRDFN,LRSS,0)=$P(^LR(LRDFN,LRSS,0),U,1,2)_U_LRIDT_U_(1+$P(^(0),U,4)),^LR(LRDFN,LRSS,LRIDT,0)=LRNT_"^^^^"_LRSPEC_"^"_^LRO(68,LRAA,1,LRAD,1,LRAN,.2)
Q
L1 S LRAA=$O(^LRO(68,LRAA)) S:LRAA<1 LREND=1 Q:LREND S %DT="E",LRSS=$G(^LRO(68,LRAA,0))
S LRRLOVR=$P(LRSS,U,3),LRSS=$P(LRSS,U,2),LRAD=+$S(LRRLOVR="Y":$E(DT,1,3)_"0000",LRRLOVR="M":$E(DT,1,5)_"00",1:DT)
Q
LREND S LREND=1 Q
REQUE S ZTRTN="^LRCONJAM",ZTDTH=$H+1_",1",ZTIO="" D ^%ZTLOAD K ZTRTN,ZTDTH,ZTIO,ZTSK Q
LRTST S LRTST="",K=0 F S K=$O(^LAB(62.3,LRIFN,2,K)) Q:K<1 S LRTST=LRTST_+^LAB(62.3,LRIFN,2,K,0)_"^"
Q
ORDER S LROUTINE=$P(^LAB(69.9,1,3),U,2),LRDFN=+$S($D(^LAB(62.3,LRIFN,"LR")):^("LR"),1:0),LRDPF=62.3 Q:LRDFN<1 S LRSPEC=$S($L($P(^LAB(62.3,LRIFN,0),U,5)):$P(^(0),U,5),1:$P(^LAB(69.9,1,1),U,5))
I '$D(ZTQUEUED),$D(^LAB(69.9,1,"RO")),+$H'=^("RO") W $C(7),!,"ROLLOVER ",$S($P(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")," ACCESSIONING SHOULDN'T BE DONE NOW.",$C(7),!," Are you sure you want to continue"
I $T S %=2 D YN^DICN W:%=0 !,"Not sure?" I %'=1 W !,"OK, try later." Q
FS S LRNT=$$NOW^LRAFUNC1,LRIDT=9999999-LRNT G FS:$D(^LR(LRDFN,LRSS,LRIDT))
L +^LRO(69,DT):1 S:'$D(^LRO(69,DT,0)) ^(0)=$P(^LRO(69,0),U,1,2)_U_LRAD_U_(1+$P(^(0),U,4)),^LRO(69,DT,0)=LRAD,^LRO(69,"B",DT,DT)=""
S LRSN=1+$S($D(^LRO(69,DT,1,0)):$P(^(0),U,3),1:0),LRSUM=1+$S($D(^LRO(69,DT,1,0)):$P(^(0),U,4),1:0)
QSN IF $D(^LRO(69,DT,1,LRSN)) S LRSN=LRSN+1 G QSN
S ^LRO(69,DT,1,LRSN,0)=LRDFN_"^^^LC^"_LRNT_"^^^"_LRNT L -^LRO(69,DT) D ORDER^LROW2 S ^LRO(69,DT,1,LRSN,.1)=LRORD,^(1)=LRNT_"^1^^C",^(3)=LRNT
K LRTEST F LRTCNT=1:1 S LRTT=$P(LRTST,U,LRTCNT) Q:LRTT<1 S LRTEST(LRTCNT)=LRTT,^LRO(69,DT,1,LRSN,2,LRTCNT,0)=LRTT_U_LROUTINE,^LRO(69,DT,1,LRSN,2,"B",LRTT,LRTCNT)=""
S LRTCNT=LRTCNT-1 G FAIL:'LRTCNT S ^LRO(69,DT,1,LRSN,2,0)="^69.03PA^"_LRTCNT_"^"_LRTCNT
S DA=LRAD,^LRO(69,DT,1,"AA",LRDFN,LRSN)="",^LRO(69,DT,1,0)="^69.01PA^"_LRSN_U_LRSUM,^LRO(69,"C",LRORD,DT,LRSN)=""
S ^LRO(69,DT,1,LRSN,4,0)="^69.02PA^1^1"
S ^LRO(69,DT,1,LRSN,4,1,0)=LRSPEC
Q
FAIL K ^LRO(69,DT,1,LRSN),^LRO(69,DT,1,"AA",LRDFN,LRSN),^LRO(69,"C",LRORD,DT,LRSN) Q
LOAD ;from LRLL4
S LRSN=-1,LRPHSET=1,LRSS="CH",LRAD=DT,LRDTN=DT,LRINC=0,LRURG="",LRSAMP="",LRSPEC="",LRTCNT=0 D ORDER Q:'LRTCNT D ^LRWLST
K LRPHSET Q
END K J,K,LRAA,LRACC,LRAD,LRAN,LRCCOM,LRCDT,LRCN,LRDFN,LRDPF,LRDTN,LREAL,LRGCOM,LRIDT,LRIFN,LRIN,LRINC,LRIOZERO,LRIX,LRLBLBP,LRLLOC,LRNCWL,LRNIDT,LRNT,LROCN,LRODT,LROID,LROLRDFN,LRORD,LROSN,LROUTINE,LRPR,LRPRAC,LRRB,LRRLOVR,LRSAMP,LRSN
K LRSPCDSC,LRSPEC,LRST,LRSUM,LRTCNT,LRTJ,LRTS,LRTST,LRTT,LRUNQ,LRURG,LRWLC,N,PNM,S5,SSN,X,Y,Z,ZTSK,LRHCT,LRPARAM
Q
T I $D(^LRO(69,DT,1,LRSN,2,"B",LRTEST(K))) S X=$O(^(LRTEST(K),0)),$P(^LRO(69,DT,1,LRSN,2,X,0),"^",3,5)=LRAD_"^"_LRAA_"^"_LRAN
S:'$D(LRURG) LRURG="" S LRTS=LRTEST(K) D CAP^LRWLST12
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCONJAM 4536 printed Dec 13, 2024@02:13:49 Page 2
LRCONJAM ;SLC/CJS,MILW/JMC - JAM CONTROLS ONTO ACCESSION ;2/19/91 10:31 ; 9/20/19 2:55pm
+1 ;;5.2;LAB SERVICE;**65,531**;Sep 27, 1994;Build 7
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
SET LREND=0
SET U="^"
SET LRAA=0
SET LRPARAM="1^"_$PIECE($GET(^LAB(69.9,1,0)),U,2,99)
DO DT^LRX
DO VIDEO^LRPARAM
DO L
DO END
QUIT
L DO L1
IF LREND
KILL D,DA,LREND,LRSS,LRTEST,LRYR
QUIT
+1 SET LRCN=0
FOR
SET LRCN=$ORDER(^LRO(68,LRAA,.5,LRCN))
if LRCN<1
QUIT
SET LRINC=0
DO L2
+2 GOTO L
L2 SET LRAN=0
FOR
SET LRAN=$ORDER(^LRO(68,LRAA,.5,LRCN,1,LRAN))
if LRAN<1
QUIT
SET LRIFN=+^LRO(68,LRAA,.5,LRCN,1,LRAN,0)
DO LRTST
DO SETUP
LOCK -^LRO(68,LRAA)
LOCK -^LRO(69,DT)
+1 QUIT
SETUP DO ORDER
if LRDFN<1
QUIT
if 'LRTCNT
QUIT
+1 LOCK +^LRO(68,LRAA):1
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN))
LOCK -^LRO(68,LRAA)
DO FAIL
QUIT
+2 IF $DATA(^LRO(68,LRAA,1,LRAD,0))[0
SET ^(0)=LRAD
SET ^(1,0)="^68.02PA^"
IF $DATA(^LRO(68,LRAA,1,0))[0
SET ^(0)="^68.01DA^"_LRAD_"^"
+3 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,0)=LRDFN_"^62.3^"_$PIECE(LRNT,".")_U_DT_U_LRSN
SET ^(3)=LRNT_"^^"_LRNT_"^^"_LRIDT
SET ^(.1)=LRORD
+4 SET ^LRO(68,LRAA,1,LRAD,1,"E",LRNT,LRAN)=""
SET ^LRO(68,LRAA,1,LRAD,1,"D",LRORD,LRAN)=""
+5 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,.2)=$PIECE(^LRO(68,LRAA,0),U,11)_" "_$SELECT(LRAD["0000":$EXTRACT(LRAD,2,3),1:$EXTRACT(LRAD,4,7))_" "_LRAN
SET LRHCT=""
+6 ;LR*5.2*531 SET PARENT TEST (#8.1)
+7 FOR K=1:1:LRTCNT
SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST(K),0)=LRTEST(K)_U_LROUTINE
SET $PIECE(^(0),U,9)=LRTEST(K)
SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRTEST(K),LRTEST(K))=""
if LRTEST(K)>LRHCT
SET LRHCT=LRTEST(K)
DO T
+8 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)="^68.04PA^"_LRHCT_"^"_LRTCNT
+9 if LRSPEC
SET ^LRO(68,LRAA,1,LRAD,1,LRAN,5,0)="^68.05PA^1^1"
SET ^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)=LRSPEC
+10 ;Creates UID for controls and check for automatic downloading
SET LRUID=$$LRUID^LRX(LRAA,LRAD,LRAN)
DO EN^LA7ADL(LRUID)
+11 IF '$DATA(^LR(LRDFN,LRSS,0))
SET ^LR(LRDFN,LRSS,0)=U_$PIECE(^DD(63,$ORDER(^DD(63,"GL",LRSS,0,0)),0),U,2)_U
+12 SET ^LR(LRDFN,LRSS,0)=$PIECE(^LR(LRDFN,LRSS,0),U,1,2)_U_LRIDT_U_(1+$PIECE(^(0),U,4))
SET ^LR(LRDFN,LRSS,LRIDT,0)=LRNT_"^^^^"_LRSPEC_"^"_^LRO(68,LRAA,1,LRAD,1,LRAN,.2)
+13 QUIT
L1 SET LRAA=$ORDER(^LRO(68,LRAA))
if LRAA<1
SET LREND=1
if LREND
QUIT
SET %DT="E"
SET LRSS=$GET(^LRO(68,LRAA,0))
+1 SET LRRLOVR=$PIECE(LRSS,U,3)
SET LRSS=$PIECE(LRSS,U,2)
SET LRAD=+$SELECT(LRRLOVR="Y":$EXTRACT(DT,1,3)_"0000",LRRLOVR="M":$EXTRACT(DT,1,5)_"00",1:DT)
+2 QUIT
LREND SET LREND=1
QUIT
REQUE SET ZTRTN="^LRCONJAM"
SET ZTDTH=$HOROLOG+1_",1"
SET ZTIO=""
DO ^%ZTLOAD
KILL ZTRTN,ZTDTH,ZTIO,ZTSK
QUIT
LRTST SET LRTST=""
SET K=0
FOR
SET K=$ORDER(^LAB(62.3,LRIFN,2,K))
if K<1
QUIT
SET LRTST=LRTST_+^LAB(62.3,LRIFN,2,K,0)_"^"
+1 QUIT
ORDER SET LROUTINE=$PIECE(^LAB(69.9,1,3),U,2)
SET LRDFN=+$SELECT($DATA(^LAB(62.3,LRIFN,"LR")):^("LR"),1:0)
SET LRDPF=62.3
if LRDFN<1
QUIT
SET LRSPEC=$SELECT($LENGTH($PIECE(^LAB(62.3,LRIFN,0),U,5)):$PIECE(^(0),U,5),1:$PIECE(^LAB(69.9,1,1),U,5))
+1 IF '$DATA(ZTQUEUED)
IF $DATA(^LAB(69.9,1,"RO"))
IF +$HOROLOG'=^("RO")
WRITE $CHAR(7),!,"ROLLOVER ",$SELECT($PIECE(^("RO"),U,2):"IS RUNNING.",1:"HAS NOT RUN.")," ACCESSIONING SHOULDN'T BE DONE NOW.",$CHAR(7),!," Are you sure you want to continue"
+2 IF $TEST
SET %=2
DO YN^DICN
if %=0
WRITE !,"Not sure?"
IF %'=1
WRITE !,"OK, try later."
QUIT
FS SET LRNT=$$NOW^LRAFUNC1
SET LRIDT=9999999-LRNT
if $DATA(^LR(LRDFN,LRSS,LRIDT))
GOTO FS
+1 LOCK +^LRO(69,DT):1
if '$DATA(^LRO(69,DT,0))
SET ^(0)=$PIECE(^LRO(69,0),U,1,2)_U_LRAD_U_(1+$PIECE(^(0),U,4))
SET ^LRO(69,DT,0)=LRAD
SET ^LRO(69,"B",DT,DT)=""
+2 SET LRSN=1+$SELECT($DATA(^LRO(69,DT,1,0)):$PIECE(^(0),U,3),1:0)
SET LRSUM=1+$SELECT($DATA(^LRO(69,DT,1,0)):$PIECE(^(0),U,4),1:0)
QSN IF $DATA(^LRO(69,DT,1,LRSN))
SET LRSN=LRSN+1
GOTO QSN
+1 SET ^LRO(69,DT,1,LRSN,0)=LRDFN_"^^^LC^"_LRNT_"^^^"_LRNT
LOCK -^LRO(69,DT)
DO ORDER^LROW2
SET ^LRO(69,DT,1,LRSN,.1)=LRORD
SET ^(1)=LRNT_"^1^^C"
SET ^(3)=LRNT
+2 KILL LRTEST
FOR LRTCNT=1:1
SET LRTT=$PIECE(LRTST,U,LRTCNT)
if LRTT<1
QUIT
SET LRTEST(LRTCNT)=LRTT
SET ^LRO(69,DT,1,LRSN,2,LRTCNT,0)=LRTT_U_LROUTINE
SET ^LRO(69,DT,1,LRSN,2,"B",LRTT,LRTCNT)=""
+3 SET LRTCNT=LRTCNT-1
if 'LRTCNT
GOTO FAIL
SET ^LRO(69,DT,1,LRSN,2,0)="^69.03PA^"_LRTCNT_"^"_LRTCNT
+4 SET DA=LRAD
SET ^LRO(69,DT,1,"AA",LRDFN,LRSN)=""
SET ^LRO(69,DT,1,0)="^69.01PA^"_LRSN_U_LRSUM
SET ^LRO(69,"C",LRORD,DT,LRSN)=""
+5 SET ^LRO(69,DT,1,LRSN,4,0)="^69.02PA^1^1"
+6 SET ^LRO(69,DT,1,LRSN,4,1,0)=LRSPEC
+7 QUIT
FAIL KILL ^LRO(69,DT,1,LRSN),^LRO(69,DT,1,"AA",LRDFN,LRSN),^LRO(69,"C",LRORD,DT,LRSN)
QUIT
LOAD ;from LRLL4
+1 SET LRSN=-1
SET LRPHSET=1
SET LRSS="CH"
SET LRAD=DT
SET LRDTN=DT
SET LRINC=0
SET LRURG=""
SET LRSAMP=""
SET LRSPEC=""
SET LRTCNT=0
DO ORDER
if 'LRTCNT
QUIT
DO ^LRWLST
+2 KILL LRPHSET
QUIT
END KILL J,K,LRAA,LRACC,LRAD,LRAN,LRCCOM,LRCDT,LRCN,LRDFN,LRDPF,LRDTN,LREAL,LRGCOM,LRIDT,LRIFN,LRIN,LRINC,LRIOZERO,LRIX,LRLBLBP,LRLLOC,LRNCWL,LRNIDT,LRNT,LROCN,LRODT,LROID,LROLRDFN,LRORD,LROSN,LROUTINE,LRPR,LRPRAC,LRRB,LRRLOVR,LRSAMP,LRSN
+1 KILL LRSPCDSC,LRSPEC,LRST,LRSUM,LRTCNT,LRTJ,LRTS,LRTST,LRTT,LRUNQ,LRURG,LRWLC,N,PNM,S5,SSN,X,Y,Z,ZTSK,LRHCT,LRPARAM
+2 QUIT
T IF $DATA(^LRO(69,DT,1,LRSN,2,"B",LRTEST(K)))
SET X=$ORDER(^(LRTEST(K),0))
SET $PIECE(^LRO(69,DT,1,LRSN,2,X,0),"^",3,5)=LRAD_"^"_LRAA_"^"_LRAN
+1 if '$DATA(LRURG)
SET LRURG=""
SET LRTS=LRTEST(K)
DO CAP^LRWLST12
+2 QUIT
