- 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 Mar 13, 2025@21:11:57 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
