LRAPL ;SLC/BA/AVAMC/REG/CYM - ANATOMIC PATH LABELS ;2/13/98 12:27 ;
;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
S LRDICS="SPCYEM" D ^LRAP G:'$D(Y) END
ASK S %DT="",X="T" D ^%DT S LR(5)=$E(Y,1,3)+1700 W !,"Enter year: ",LR(5),"// " R X:DTIME G:'$T!(X[U) END S:X="" X=LR(5)
S %DT="EQ" D ^%DT G:X["?" ASK G:Y<1 END S LR(2)=$E(Y,1,3) W " ",LR(2)+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
W !!?33,"REMEMBER TO",!?13,"ALIGN THE PRINT HEAD ON THE FIRST LINE OF THE LABEL"
S LR(3)=LR(3)-1,LR(1)=$S($D(^LRO(69.2,LRAA,0)):$P(^(0),U,7),1:"")
I W !!?20,"ENTER NUMBER OF LINES FROM",!?20,"TOP OF ONE LABEL TO ANOTHER: ",LR(1),$S(LR(1):"// ",1:"") R X:DTIME Q:'$T!(X[U) S X=$S(X="":LR(1),$L(X)>2:X=1,1:X)
A X $P(^DD(69.2,.07,0),U,5,99) I '$D(X) W:$D(^DD(69.2,.07,3)) !,$C(7),^(3) X:$D(^(4)) ^(4) G I
I X["?" S X="ZZZ" G A
S LR(1)=X
S ZTRTN="QUE^LRAPL",ZTDESC="Anatomic Path Labels",ZTSAVE("LR*")="" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO D XR^LRU
F A=LR(3):0 S A=$O(^LR(LRXREF,LR(2),LRABV,A)) Q:'A!(A>LR(4)) S LRDFN=+$O(^(A,0)),LRI=+$O(^(LRDFN,0)) D W
D END^LRUTL,END Q
W S LRX=$G(^LR(LRDFN,LRSS,LRI,0)) I LRX="" K ^LR(LRXREF,LR(2),LRABV,A,LRDFN,LRI) Q
Q:$P($P(LRX,U,6)," ")'=LRABV
S W=^LR(LRDFN,0),Y=$P(W,"^",3),(LRDPF,P)=$P(W,"^",2),X=^DIC(P,0,"GL"),X=@(X_Y_",0)") S P(1)=$P(X,"^"),SSN=$P(X,"^",9),S(6)=$P(LRX,"^",6),LRSPECDT=+LRX D SSN^LRU
F B=0:0 S B=$O(^LR(LRDFN,LRSS,LRI,.1,B)) Q:'B S S(2)=^(B,0) D P
Q
P W !,S(6)," Taken: ",$$FMTE^XLFDT(LRSPECDT,"D")
W !,P(1)," ",SSN
W !,$P(S(2),"^") F X=4:1:LR(1) W !
Q
HELP W $C(7),!!,"Enter numbers only",! Q
END K LRSPECDT D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPL 1876 printed Nov 22, 2024@17:17:42 Page 2
LRAPL ;SLC/BA/AVAMC/REG/CYM - ANATOMIC PATH LABELS ;2/13/98 12:27 ;
+1 ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
+2 SET LRDICS="SPCYEM"
DO ^LRAP
if '$DATA(Y)
GOTO END
ASK SET %DT=""
SET X="T"
DO ^%DT
SET LR(5)=$EXTRACT(Y,1,3)+1700
WRITE !,"Enter year: ",LR(5),"// "
READ X:DTIME
if '$TEST!(X[U)
GOTO END
if X=""
SET X=LR(5)
+1 SET %DT="EQ"
DO ^%DT
if X["?"
GOTO ASK
if Y<1
GOTO END
SET LR(2)=$EXTRACT(Y,1,3)
WRITE " ",LR(2)+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 WRITE !!?33,"REMEMBER TO",!?13,"ALIGN THE PRINT HEAD ON THE FIRST LINE OF THE LABEL"
+4 SET LR(3)=LR(3)-1
SET LR(1)=$SELECT($DATA(^LRO(69.2,LRAA,0)):$PIECE(^(0),U,7),1:"")
I WRITE !!?20,"ENTER NUMBER OF LINES FROM",!?20,"TOP OF ONE LABEL TO ANOTHER: ",LR(1),$SELECT(LR(1):"// ",1:"")
READ X:DTIME
if '$TEST!(X[U)
QUIT
SET X=$SELECT(X="":LR(1),$LENGTH(X)>2:X=1,1:X)
A XECUTE $PIECE(^DD(69.2,.07,0),U,5,99)
IF '$DATA(X)
if $DATA(^DD(69.2,.07,3))
WRITE !,$CHAR(7),^(3)
if $DATA(^(4))
XECUTE ^(4)
GOTO I
+1 IF X["?"
SET X="ZZZ"
GOTO A
+2 SET LR(1)=X
+3 SET ZTRTN="QUE^LRAPL"
SET ZTDESC="Anatomic Path Labels"
SET ZTSAVE("LR*")=""
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
DO XR^LRU
+1 FOR A=LR(3):0
SET A=$ORDER(^LR(LRXREF,LR(2),LRABV,A))
if 'A!(A>LR(4))
QUIT
SET LRDFN=+$ORDER(^(A,0))
SET LRI=+$ORDER(^(LRDFN,0))
DO W
+2 DO END^LRUTL
DO END
QUIT
W SET LRX=$GET(^LR(LRDFN,LRSS,LRI,0))
IF LRX=""
KILL ^LR(LRXREF,LR(2),LRABV,A,LRDFN,LRI)
QUIT
+1 if $PIECE($PIECE(LRX,U,6)," ")'=LRABV
QUIT
+2 SET W=^LR(LRDFN,0)
SET Y=$PIECE(W,"^",3)
SET (LRDPF,P)=$PIECE(W,"^",2)
SET X=^DIC(P,0,"GL")
SET X=@(X_Y_",0)")
SET P(1)=$PIECE(X,"^")
SET SSN=$PIECE(X,"^",9)
SET S(6)=$PIECE(LRX,"^",6)
SET LRSPECDT=+LRX
DO SSN^LRU
+3 FOR B=0:0
SET B=$ORDER(^LR(LRDFN,LRSS,LRI,.1,B))
if 'B
QUIT
SET S(2)=^(B,0)
DO P
+4 QUIT
P WRITE !,S(6)," Taken: ",$$FMTE^XLFDT(LRSPECDT,"D")
+1 WRITE !,P(1)," ",SSN
+2 WRITE !,$PIECE(S(2),"^")
FOR X=4:1:LR(1)
WRITE !
+3 QUIT
HELP WRITE $CHAR(7),!!,"Enter numbers only",!
QUIT
END KILL LRSPECDT
DO V^LRU
QUIT
