LRUPUM ;AVAMC/REG - USER MANUAL ;3/9/94 13:31
;;5.2;LAB SERVICE;;Sep 27, 1994
D END S DIC="^LAB(68.45,",DIC(0)="AEQM" D ^DIC K DIC G:Y<1 END S LRI=+Y,LRN=$P(Y,U,2)
I '$O(^LAB(68.45,LRI,1,0)) W $C(7),!,"No data elements selected for ",LRN G END
S ZTRTN="QUE^LRUPUM" D BEG^LRUTL Q:POP!($D(ZTSK))
QUE U IO S DIWL=10,DIWR=IOM-5,LRL=DIWR-DIWL-5,DIWF="W",(LR("Q"),LR("F"),LRQ)=0,LRQ(1)=^DD("SITE") D L^LRU D H S LR("F")=1
F LRA=0:0 S LRA=$O(^LAB(68.45,LRI,1,LRA)) Q:'LRA D:$Y>(IOSL-5) H Q:LR("Q") S LRE=^(LRA,0),LRX=$P(LRE,","),LRY=$P(LRE,",",2) I LRX]"",LRY]"" D W
D END,END^LRUTL Q
W S X=$S($D(^DD(LRX,LRY,0)):^(0),1:"") Q:X="" W !,LRE,?16,$P(X,"^") I $P(X,"^",2)["S" S LRD=$P(X,"^",3),LRC=";" D B
F LRO=3,12 S LRD=$S($D(^DD(LRX,LRY,LRO)):^(LRO),1:""),LRC=" " I LRD]"" D B
K ^TMP($J) S LRB=0 F LRZ=0:1 S LRB=$O(^DD(LRX,LRY,21,LRB)) Q:'LRB D:$Y>(IOSL-5) H1 Q:LR("Q") S X=^DD(LRX,LRY,21,LRB,0) D ^DIWP
Q:LR("Q") D:LRZ ^DIWW Q
B Q:LR("Q") I $L(LRD)<LRL W !?DIWL-1,LRD,! W:LRC=" " ! D:$Y>(IOSL-6) H1 Q
S LRK="",Z=1 F %=1:1 Q:'$L(LRD) D:$L(LRK)>LRL C S:LRK]"" LRK=LRK_LRC S LRK=LRK_$P(LRD,LRC),LRD=$P(LRD,LRC,2,99),Z=Z+1
W:LRK]"" !?DIWL-1,LRK,! W:LRC=" " ! Q
C S LRK=$P(LRK,LRC,1,Z) D:$Y>(IOSL-6) H1 Q:LR("Q") W !?DIWL-1,LRK S Z=1,LRK="" Q
;
H Q:LR("Q") I IOST?1"C".E,LR("F") D M^LRU Q:LR("Q")
S LRQ=LRQ+1,X="N",%DT="T" D ^%DT,D^LRU W @IOF,!,Y,?25,LRQ(1),?73,"Pg ",LRQ,!,"DATA ELEMENTS FOR ",LRN,!,LR("%") Q
;
H1 D H Q:LR("Q") W !,LRE,?16,$P(^DD(LRX,LRY,0),"^")," (Continued)" Q
;
EN ;Edit USER GROUP MANUAL file
D END W ! S (DIC,DIE)="^LAB(68.45,",DIC(0)="AEQLM",DLAYGO=68
D ^DIC K DIC G:Y<1 END S DA=+Y,DR=".01:99" D ^DIE K DLAYGO G EN
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUPUM 1702 printed Dec 13, 2024@02:22:03 Page 2
LRUPUM ;AVAMC/REG - USER MANUAL ;3/9/94 13:31
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 DO END
SET DIC="^LAB(68.45,"
SET DIC(0)="AEQM"
DO ^DIC
KILL DIC
if Y<1
GOTO END
SET LRI=+Y
SET LRN=$PIECE(Y,U,2)
+3 IF '$ORDER(^LAB(68.45,LRI,1,0))
WRITE $CHAR(7),!,"No data elements selected for ",LRN
GOTO END
+4 SET ZTRTN="QUE^LRUPUM"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
QUIT
QUE USE IO
SET DIWL=10
SET DIWR=IOM-5
SET LRL=DIWR-DIWL-5
SET DIWF="W"
SET (LR("Q"),LR("F"),LRQ)=0
SET LRQ(1)=^DD("SITE")
DO L^LRU
DO H
SET LR("F")=1
+1 FOR LRA=0:0
SET LRA=$ORDER(^LAB(68.45,LRI,1,LRA))
if 'LRA
QUIT
if $Y>(IOSL-5)
DO H
if LR("Q")
QUIT
SET LRE=^(LRA,0)
SET LRX=$PIECE(LRE,",")
SET LRY=$PIECE(LRE,",",2)
IF LRX]""
IF LRY]""
DO W
+2 DO END
DO END^LRUTL
QUIT
W SET X=$SELECT($DATA(^DD(LRX,LRY,0)):^(0),1:"")
if X=""
QUIT
WRITE !,LRE,?16,$PIECE(X,"^")
IF $PIECE(X,"^",2)["S"
SET LRD=$PIECE(X,"^",3)
SET LRC=";"
DO B
+1 FOR LRO=3,12
SET LRD=$SELECT($DATA(^DD(LRX,LRY,LRO)):^(LRO),1:"")
SET LRC=" "
IF LRD]""
DO B
+2 KILL ^TMP($JOB)
SET LRB=0
FOR LRZ=0:1
SET LRB=$ORDER(^DD(LRX,LRY,21,LRB))
if 'LRB
QUIT
if $Y>(IOSL-5)
DO H1
if LR("Q")
QUIT
SET X=^DD(LRX,LRY,21,LRB,0)
DO ^DIWP
+3 if LR("Q")
QUIT
if LRZ
DO ^DIWW
QUIT
B if LR("Q")
QUIT
IF $LENGTH(LRD)<LRL
WRITE !?DIWL-1,LRD,!
if LRC=" "
WRITE !
if $Y>(IOSL-6)
DO H1
QUIT
+1 SET LRK=""
SET Z=1
FOR %=1:1
if '$LENGTH(LRD)
QUIT
if $LENGTH(LRK)>LRL
DO C
if LRK]""
SET LRK=LRK_LRC
SET LRK=LRK_$PIECE(LRD,LRC)
SET LRD=$PIECE(LRD,LRC,2,99)
SET Z=Z+1
+2 if LRK]""
WRITE !?DIWL-1,LRK,!
if LRC=" "
WRITE !
QUIT
C SET LRK=$PIECE(LRK,LRC,1,Z)
if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
WRITE !?DIWL-1,LRK
SET Z=1
SET LRK=""
QUIT
+1 ;
H if LR("Q")
QUIT
IF IOST?1"C".E
IF LR("F")
DO M^LRU
if LR("Q")
QUIT
+1 SET LRQ=LRQ+1
SET X="N"
SET %DT="T"
DO ^%DT
DO D^LRU
WRITE @IOF,!,Y,?25,LRQ(1),?73,"Pg ",LRQ,!,"DATA ELEMENTS FOR ",LRN,!,LR("%")
QUIT
+2 ;
H1 DO H
if LR("Q")
QUIT
WRITE !,LRE,?16,$PIECE(^DD(LRX,LRY,0),"^")," (Continued)"
QUIT
+1 ;
EN ;Edit USER GROUP MANUAL file
+1 DO END
WRITE !
SET (DIC,DIE)="^LAB(68.45,"
SET DIC(0)="AEQLM"
SET DLAYGO=68
+2 DO ^DIC
KILL DIC
if Y<1
GOTO END
SET DA=+Y
SET DR=".01:99"
DO ^DIE
KILL DLAYGO
GOTO EN
+3 ;
END DO V^LRU
QUIT
