LRAPSL.m

LRAPSL ;AVAMC/REG/CYM - ANATOMIC PATH SLIDE LABELS ;2/13/98  13:41 ;

 ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994

 D ^LRAP G:'$D(Y) END I LRSS="AU" D AU^LRAPBS1 G:J END S:'$D(LRW(0)) LRW(0)=$O(^LAB(60,"B","AUTOPSY H & E",0))

ASK S LRZ=1,%DT="",X="T" D ^%DT S LRY=$E(Y,1,3)+1700 W !,"Enter year: ",LRY,"// " R X:DTIME G:'$T!(X[U) END S:X="" X=LRY

 S %DT="EQ" D ^%DT G:Y<1 ASK S LRY=$E(Y,1,3),LRH(0)=LRY+1700 W "  ",LRH(0)

 S LRR=0 W !!,"Reprint slide labels " S %=2 D YN^LRU G:%<1 END I %=1 S LRR=1 G R

 W !!,"Add/Delete slide labels to print " S %=2 D YN^LRU G:%<1 END I %=1 D S^LRAPST,^LRAPSL1

 W !!,"Print ",LRO(68)," slide labels for ",LRY+1700

R R !!,"Start with accession number: ",X:DTIME G:X=""!(X[U) END S LR(3)=X I +X'=X D HELP G R

RR R !,"Go    to   accession number: LAST// ",LR(4):DTIME G:'$T!(LR(4)[U) END S:LR(4)="" LR(4)=9999999 I LR(4)'=+LR(4) D HELP G RR

 S:'LR(4) LR(4)=9999999

 I LR(4)<LR(3) S X=LR(3),LR(3)=LR(4),LR(4)=X

 D SET W !!,"Just a moment while I check to see if there are labels to print",!! D C I '$D(LRZ(1)) W $C(7),?20,"There are no labels to print" G END

 K LRZ S ZTRTN="QUE^LRAPSL" D BEG^LRUTL G:POP!($D(ZTSK)) END

QUE U IO W $C(13) D SET

 D C F A=0:0 S A=$O(^TMP($J,A)) Q:'A  D W

 D END^LRUTL,END Q

C F A=LR(3)-1:0 S A=$O(^LR(LRXREF,LRY,LRABV,A)) Q:'A!(A>LR(4))  S LRDFN=$O(^(A,0)),LRI=$O(^(LRDFN,0)) D S

 Q

W W !,LRABV,?10,LRABV,?20,LRABV,?30,LRABV,?40,LRABV,?50,LRABV

 F C=2:1:4 W ! F B=0:1:5 W ?B*10,$S($D(^TMP($J,A,B+1,C)):^(C),1:"")

 W !,LR(12),?10,LR(12),?20,LR(12),?30,LR(12),?40,LR(12),?50,LR(12)

 W ! Q

S I LRSS="AU" D AU Q

 F B=0:0 S B=$O(^LR(LRDFN,LRSS,LRI,.1,B)) Q:'B!($D(LRZ(1)))  F J=0:0 S J=$O(^LR(LRDFN,LRSS,LRI,.1,B,J)) Q:'J!($D(LRZ(1)))  F C=0:0 S C=$O(^LR(LRDFN,LRSS,LRI,.1,B,J,C)) Q:'C!($D(LRZ(1)))  S LRB=$P(^(C,0),"^") D T

 Q

T F E=0:0 S E=$O(^LR(LRDFN,LRSS,LRI,.1,B,J,C,1,E)) Q:'E  S X=^(E,0),F=$S('LRR:$P(X,"^",7),1:$P(X,"^",6)) D:'F X I F S:$D(LRZ) LRZ(1)=1 Q:$D(LRZ)  S $P(^(0),"^",7)=0,LR(9)=$S($D(^LAB(60,E,.1)):$P(^(.1),"^"),1:"") D P

 Q

P F G=1:1:F S LR(6)=LR(6)+1,LR(8)=LR(6)#6,LR(7)=LR(6)\6+1 S:'LR(8) LR(7)=LR(7)-1 S:'LR(8) LR(8)=6 S ^TMP($J,LR(7),LR(8),2)=LR(1)_A,^(3)=$E(LRB,1,9),^(4)=LR(9)

 Q

X S F=$P(X,"^",2)+$P(X,"^",3) S:LRSS'="AU"&('$D(LRZ)) $P(^LR(LRDFN,LRSS,LRI,.1,B,J,C,1,E,0),"^",6)=F I LRSS="AU"&('$D(LRZ)) S $P(^LR(LRDFN,33,B,J,C,1,E,0),"^",6)=F

 S:'LRR F=F-$P(X,"^",6) S:F<0 F=0 Q

AU F B=0:0 S B=$O(^LR(LRDFN,33,B)) Q:'B  F J=0:0 S J=$O(^LR(LRDFN,33,B,J)) Q:'J  F C=0:0 S C=$O(^LR(LRDFN,33,B,J,C)) Q:'C  S LRB=$P(^(C,0),"^") D AUT

 Q

AUT F E=0:0 S E=$O(^LR(LRDFN,33,B,J,C,1,E)) Q:'E  S X=^(E,0),F=$S('LRR:$P(X,"^",7),1:$P(X,"^",6)) D:'F X I F S:$D(LRZ) LRZ(1)=1 Q:$D(LRZ)  S $P(^(0),"^",7)=0,LR(9)=$S($D(^LAB(60,E,.1)):$P(^(.1),"^"),1:"") D P

 Q

CK I LRR S:'F F=1 Q

 S:$P(X,"^",7)="" F=1 Q

HELP W $C(7),!!,"Enter numbers only",! Q

END D V^LRU Q

SET K ^TMP($J) S (LR("FORM"),LR("LINE"))=1,LR(12)=$S(DUZ("AG")="V":"VAMC "_+$$SITE^VASITE,1:$E($$INS^LRU,1,9)),LR(6)=0,LR(1)=($E(LRY,1,3)+1700)_"-",LRXREF="A"_LRSS_"A" Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRAPSL   3038     printed  Feb 18, 2025@23:34:13                                                                                                                                                                                                      Page 2

LRAPSL    ;AVAMC/REG/CYM - ANATOMIC PATH SLIDE LABELS ;2/13/98  13:41 ;

 +1       ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994

 +2        DO ^LRAP

           if '$DATA(Y)

               GOTO END

           IF LRSS="AU"

               DO AU^LRAPBS1

               if J

                   GOTO END

               if '$DATA(LRW(0))

                   SET LRW(0)=$ORDER(^LAB(60,"B","AUTOPSY H & E",0))

ASK        SET LRZ=1

           SET %DT=""

           SET X="T"

           DO ^%DT

           SET LRY=$EXTRACT(Y,1,3)+1700

           WRITE !,"Enter year: ",LRY,"// "

           READ X:DTIME

           if '$TEST!(X[U)

               GOTO END

           if X=""

               SET X=LRY

 +1        SET %DT="EQ"

           DO ^%DT

           if Y<1

               GOTO ASK

           SET LRY=$EXTRACT(Y,1,3)

           SET LRH(0)=LRY+1700

           WRITE "  ",LRH(0)

 +2        SET LRR=0

           WRITE !!,"Reprint slide labels "

           SET %=2

           DO YN^LRU

           if %<1

               GOTO END

           IF %=1

               SET LRR=1

               GOTO R

 +3        WRITE !!,"Add/Delete slide labels to print "

           SET %=2

           DO YN^LRU

           if %<1

               GOTO END

           IF %=1

               DO S^LRAPST

               DO ^LRAPSL1

 +4        WRITE !!,"Print ",LRO(68)," slide labels for ",LRY+1700

R          READ !!,"Start with accession number: ",X:DTIME

           if X=""!(X[U)

               GOTO END

           SET LR(3)=X

           IF +X'=X

               DO HELP

               GOTO R

RR         READ !,"Go    to   accession number: LAST// ",LR(4):DTIME

           if '$TEST!(LR(4)[U)

               GOTO END

           if LR(4)=""

               SET LR(4)=9999999

           IF LR(4)'=+LR(4)

               DO HELP

               GOTO RR

 +1        if 'LR(4)

               SET LR(4)=9999999

 +2        IF LR(4)<LR(3)

               SET X=LR(3)

               SET LR(3)=LR(4)

               SET LR(4)=X

 +3        DO SET

           WRITE !!,"Just a moment while I check to see if there are labels to print",!!

           DO C

           IF '$DATA(LRZ(1))

               WRITE $CHAR(7),?20,"There are no labels to print"

               GOTO END

 +4        KILL LRZ

           SET ZTRTN="QUE^LRAPSL"

           DO BEG^LRUTL

           if POP!($DATA(ZTSK))

               GOTO END

QUE        USE IO

           WRITE $CHAR(13)

           DO SET

 +1        DO C

           FOR A=0:0

               SET A=$ORDER(^TMP($JOB,A))

               if 'A

                   QUIT 

               DO W

 +2        DO END^LRUTL

           DO END

           QUIT 

C          FOR A=LR(3)-1:0

               SET A=$ORDER(^LR(LRXREF,LRY,LRABV,A))

               if 'A!(A>LR(4))

                   QUIT 

               SET LRDFN=$ORDER(^(A,0))

               SET LRI=$ORDER(^(LRDFN,0))

               DO S

 +1        QUIT 

W          WRITE !,LRABV,?10,LRABV,?20,LRABV,?30,LRABV,?40,LRABV,?50,LRABV

 +1        FOR C=2:1:4

               WRITE !

               FOR B=0:1:5

                   WRITE ?B*10,$SELECT($DATA(^TMP($JOB,A,B+1,C)):^(C),1:"")

 +2        WRITE !,LR(12),?10,LR(12),?20,LR(12),?30,LR(12),?40,LR(12),?50,LR(12)

 +3        WRITE !

           QUIT 

S          IF LRSS="AU"

               DO AU

               QUIT 

 +1        FOR B=0:0

               SET B=$ORDER(^LR(LRDFN,LRSS,LRI,.1,B))

               if 'B!($DATA(LRZ(1)))

                   QUIT 

               FOR J=0:0

                   SET J=$ORDER(^LR(LRDFN,LRSS,LRI,.1,B,J))

                   if 'J!($DATA(LRZ(1)))

                       QUIT 

                   FOR C=0:0

                       SET C=$ORDER(^LR(LRDFN,LRSS,LRI,.1,B,J,C))

                       if 'C!($DATA(LRZ(1)))

                           QUIT 

                       SET LRB=$PIECE(^(C,0),"^")

                       DO T

 +2        QUIT 

T          FOR E=0:0

               SET E=$ORDER(^LR(LRDFN,LRSS,LRI,.1,B,J,C,1,E))

               if 'E

                   QUIT 

               SET X=^(E,0)

               SET F=$SELECT('LRR:$PIECE(X,"^",7),1:$PIECE(X,"^",6))

               if 'F

                   DO X

               IF F

                   if $DATA(LRZ)

                       SET LRZ(1)=1

                   if $DATA(LRZ)

                       QUIT 

                   SET $PIECE(^(0),"^",7)=0

                   SET LR(9)=$SELECT($DATA(^LAB(60,E,.1)):$PIECE(^(.1),"^"),1:"")

                   DO P

 +1        QUIT 

P          FOR G=1:1:F

               SET LR(6)=LR(6)+1

               SET LR(8)=LR(6)#6

               SET LR(7)=LR(6)\6+1

               if 'LR(8)

                   SET LR(7)=LR(7)-1

               if 'LR(8)

                   SET LR(8)=6

               SET ^TMP($JOB,LR(7),LR(8),2)=LR(1)_A

               SET ^(3)=$EXTRACT(LRB,1,9)

               SET ^(4)=LR(9)

 +1        QUIT 

X          SET F=$PIECE(X,"^",2)+$PIECE(X,"^",3)

           if LRSS'="AU"&('$DATA(LRZ))

               SET $PIECE(^LR(LRDFN,LRSS,LRI,.1,B,J,C,1,E,0),"^",6)=F

           IF LRSS="AU"&('$DATA(LRZ))

               SET $PIECE(^LR(LRDFN,33,B,J,C,1,E,0),"^",6)=F

 +1        if 'LRR

               SET F=F-$PIECE(X,"^",6)

           if F<0

               SET F=0

           QUIT 

AU         FOR B=0:0

               SET B=$ORDER(^LR(LRDFN,33,B))

               if 'B

                   QUIT 

               FOR J=0:0

                   SET J=$ORDER(^LR(LRDFN,33,B,J))

                   if 'J

                       QUIT 

                   FOR C=0:0

                       SET C=$ORDER(^LR(LRDFN,33,B,J,C))

                       if 'C

                           QUIT 

                       SET LRB=$PIECE(^(C,0),"^")

                       DO AUT

 +1        QUIT 

AUT        FOR E=0:0

               SET E=$ORDER(^LR(LRDFN,33,B,J,C,1,E))

               if 'E

                   QUIT 

               SET X=^(E,0)

               SET F=$SELECT('LRR:$PIECE(X,"^",7),1:$PIECE(X,"^",6))

               if 'F

                   DO X

               IF F

                   if $DATA(LRZ)

                       SET LRZ(1)=1

                   if $DATA(LRZ)

                       QUIT 

                   SET $PIECE(^(0),"^",7)=0

                   SET LR(9)=$SELECT($DATA(^LAB(60,E,.1)):$PIECE(^(.1),"^"),1:"")

                   DO P

 +1        QUIT 

CK         IF LRR

               if 'F

                   SET F=1

               QUIT 

 +1        if $PIECE(X,"^",7)=""

               SET F=1

           QUIT 

HELP       WRITE $CHAR(7),!!,"Enter numbers only",!

           QUIT 

END        DO V^LRU

           QUIT 

SET        KILL ^TMP($JOB)

           SET (LR("FORM"),LR("LINE"))=1

           SET LR(12)=$SELECT(DUZ("AG")="V":"VAMC "_+$$SITE^VASITE,1:$EXTRACT($$INS^LRU,1,9))

           SET LR(6)=0

           SET LR(1)=($EXTRACT(LRY,1,3)+1700)_"-"

           SET LRXREF="A"_LRSS_"A"

           QUIT