LRCONJAM.m

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 ---LRCONJAM   4536     printed  Feb 18, 2025@23:39:42                                                                                                                                                                                                    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