VALMXQ11 ; alb/mjk - XQORM3 for export with LM v1 ; 3/30/93
;;1;List Manager;;Aug 13, 1993
;
;
XQORM3 ; SLC/KCM - Lookup (cont.) ;11/12/92 11:28
;;6.7;Sidewinder;;Jan 08, 1993
LOOK ;From: XQORM2
K ORUFD,ORUDA S ORUFD=0,ORUW=X
I $D(^XUTL("XQORM",XQORM,"B",X)) S ORUDA=0 F I=0:0 S ORUDA=$O(^XUTL("XQORM",XQORM,"B",X,ORUDA)) Q:ORUDA="" I '$D(ORUDA(ORUDA)) D LOOK1 Q:ORUER
S:$E(X,$L(X),1)'=" " X=$E(X,1,$L(X)-1)_$C($A($E(X,$L(X)))-1)_"~"
F I=0:0 S X=$O(^XUTL("XQORM",XQORM,"B",X)) Q:X=""!($E(X,1,$L(ORUW))'=ORUW)!(XQORM(0)["X"&(X'=ORUW)) S ORUDA=0 F I=0:0 S ORUDA=$O(^XUTL("XQORM",XQORM,"B",X,ORUDA)) Q:ORUDA="" I '$D(ORUDA(ORUDA)) D LOOK1
S ORUDA=0 Q:ORUER I ORUFD=1 S ORUDA=ORUFD(1) Q
I 'ORUFD,$L($P(ORUW," ")),(($D(XQORM("KEY",$P(ORUW," ")))&('$D(XQORM("NO^^"))))!(ORUW="ALL")) S ORUDA=ORUW Q
I 'ORUFD,XQORM(0)["A" S ORUER=1 D NF^XQORM4 I (ORUX[",")!(ORUX["-") S ORUER=0 D PICK
D:ORUFD>1 PICK ;S:'ORUFD ORUER=1
Q
LOOK1 S ORUFD=ORUFD+1,ORUFD(ORUFD)=ORUDA,ORUDA(ORUDA)=""
Q
PICK I XQORM(0)'["A" S ORUFD=0 Q
I ORUFD F J=1:1:ORUFD W:$D(^XUTL("XQORM",XQORM,ORUFD(J),0)) !,$J(J,6),?9,$P(^(0),"^",3)
F I=0:0 D PICK1 I $L(X)'>80,X?.ANP S:'$T X="^" Q:X'["?" D HELP3^XQORM5
I X="",'((ORUX[",")!(ORUX["-")) S X="^" ;reprompt if only 1 selection
S:X="^" ORUER=1 S:X="^^" (ORUER,DIROUT)=1 S ORUFD=0 Q:ORUER
I $L(X),$D(ORUFD(X)) S ORUDA=ORUFD(X),ORUFD=1 Q
D:$L(X)&(X'["^") LOOK
Q
PICK1 W !,$S(ORUX[","!(ORUX["-"):"For entry """_ORUW_""" ",1:""),$S(ORUFD:"CHOOSE 1-"_ORUFD_": ",1:"re-enter: ")
R X:$S($D(DTIME):DTIME,1:"") D:X'?.ANP CC^XQORM4 D:$L(X)>80 LL^XQORM4 D UP^XQORM1
Q
UPD ;from XQORM2
S X="",ORUSQ=ORUSQ+1 S:$D(^XUTL("XQORM",XQORM,ORUDA,0)) X=^(0) I '$L(X) S ORUER=1 Q
I $D(ORUX(ORUT,"'")) S X=$O(Y("B",ORUDA,"")) K:$L(X) Y(X),Y("B",ORUDA,X) S:$L(X) Y=Y-1 Q
S Y=Y+1,Y(ORUSQ)=$P(X,"^",1,3),Y("B",ORUDA,ORUSQ)="",$P(Y(ORUSQ),"^",4)=ORUX(ORUT) S:$D(ORUX(ORUT,"=")) Y(ORUSQ)=Y(ORUSQ)_"="_ORUX(ORUT,"=")
Q
RNG ;From: XQORM2
N K Q:X'?1.N1"-"1.N
I $P(X,"-",1)'<$P(X,"-",2) D:XQORM(0)["A" IR^XQORM4 S ORUER=1 Q
S ORUB="" F K=$P(X,"-",1):1:$P(X,"-",2) S ORUB=ORUB_K_"," I $L(ORUB)>225 D:XQORM(0)["A" LR^XQORM4 S ORUER=1 Q
S X=ORUB
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVALMXQ11 2196 printed Nov 22, 2024@17:20:32 Page 2
VALMXQ11 ; alb/mjk - XQORM3 for export with LM v1 ; 3/30/93
+1 ;;1;List Manager;;Aug 13, 1993
+2 ;
+3 ;
XQORM3 ; SLC/KCM - Lookup (cont.) ;11/12/92 11:28
+1 ;;6.7;Sidewinder;;Jan 08, 1993
LOOK ;From: XQORM2
+1 KILL ORUFD,ORUDA
SET ORUFD=0
SET ORUW=X
+2 IF $DATA(^XUTL("XQORM",XQORM,"B",X))
SET ORUDA=0
FOR I=0:0
SET ORUDA=$ORDER(^XUTL("XQORM",XQORM,"B",X,ORUDA))
if ORUDA=""
QUIT
IF '$DATA(ORUDA(ORUDA))
DO LOOK1
if ORUER
QUIT
+3 if $EXTRACT(X,$LENGTH(X),1)'=" "
SET X=$EXTRACT(X,1,$LENGTH(X)-1)_$CHAR($ASCII($EXTRACT(X,$LENGTH(X)))-1)_"~"
+4 FOR I=0:0
SET X=$ORDER(^XUTL("XQORM",XQORM,"B",X))
if X=""!($EXTRACT(X,1,$LENGTH(ORUW))'=ORUW)!(XQORM(0)["X"&(X'=ORUW))
QUIT
SET ORUDA=0
FOR I=0:0
SET ORUDA=$ORDER(^XUTL("XQORM",XQORM,"B",X,ORUDA))
if ORUDA=""
QUIT
IF '$DATA(ORUDA(ORUDA))
DO LOOK1
+5 SET ORUDA=0
if ORUER
QUIT
IF ORUFD=1
SET ORUDA=ORUFD(1)
QUIT
+6 IF 'ORUFD
IF $LENGTH($PIECE(ORUW," "))
IF (($DATA(XQORM("KEY",$PIECE(ORUW," ")))&('$DATA(XQORM("NO^^"))))!(ORUW="ALL"))
SET ORUDA=ORUW
QUIT
+7 IF 'ORUFD
IF XQORM(0)["A"
SET ORUER=1
DO NF^XQORM4
IF (ORUX[",")!(ORUX["-")
SET ORUER=0
DO PICK
+8 ;S:'ORUFD ORUER=1
if ORUFD>1
DO PICK
+9 QUIT
LOOK1 SET ORUFD=ORUFD+1
SET ORUFD(ORUFD)=ORUDA
SET ORUDA(ORUDA)=""
+1 QUIT
PICK IF XQORM(0)'["A"
SET ORUFD=0
QUIT
+1 IF ORUFD
FOR J=1:1:ORUFD
if $DATA(^XUTL("XQORM",XQORM,ORUFD(J),0))
WRITE !,$JUSTIFY(J,6),?9,$PIECE(^(0),"^",3)
+2 FOR I=0:0
DO PICK1
IF $LENGTH(X)'>80
IF X?.ANP
if '$TEST
SET X="^"
if X'["?"
QUIT
DO HELP3^XQORM5
+3 ;reprompt if only 1 selection
IF X=""
IF '((ORUX[",")!(ORUX["-"))
SET X="^"
+4 if X="^"
SET ORUER=1
if X="^^"
SET (ORUER,DIROUT)=1
SET ORUFD=0
if ORUER
QUIT
+5 IF $LENGTH(X)
IF $DATA(ORUFD(X))
SET ORUDA=ORUFD(X)
SET ORUFD=1
QUIT
+6 if $LENGTH(X)&(X'["^")
DO LOOK
+7 QUIT
PICK1 WRITE !,$SELECT(ORUX[","!(ORUX["-"):"For entry """_ORUW_""" ",1:""),$SELECT(ORUFD:"CHOOSE 1-"_ORUFD_": ",1:"re-enter: ")
+1 READ X:$SELECT($DATA(DTIME):DTIME,1:"")
if X'?.ANP
DO CC^XQORM4
if $LENGTH(X)>80
DO LL^XQORM4
DO UP^XQORM1
+2 QUIT
UPD ;from XQORM2
+1 SET X=""
SET ORUSQ=ORUSQ+1
if $DATA(^XUTL("XQORM",XQORM,ORUDA,0))
SET X=^(0)
IF '$LENGTH(X)
SET ORUER=1
QUIT
+2 IF $DATA(ORUX(ORUT,"'"))
SET X=$ORDER(Y("B",ORUDA,""))
if $LENGTH(X)
KILL Y(X),Y("B",ORUDA,X)
if $LENGTH(X)
SET Y=Y-1
QUIT
+3 SET Y=Y+1
SET Y(ORUSQ)=$PIECE(X,"^",1,3)
SET Y("B",ORUDA,ORUSQ)=""
SET $PIECE(Y(ORUSQ),"^",4)=ORUX(ORUT)
if $DATA(ORUX(ORUT,"="))
SET Y(ORUSQ)=Y(ORUSQ)_"="_ORUX(ORUT,"=")
+4 QUIT
RNG ;From: XQORM2
+1 NEW K
if X'?1.N1"-"1.N
QUIT
+2 IF $PIECE(X,"-",1)'<$PIECE(X,"-",2)
if XQORM(0)["A"
DO IR^XQORM4
SET ORUER=1
QUIT
+3 SET ORUB=""
FOR K=$PIECE(X,"-",1):1:$PIECE(X,"-",2)
SET ORUB=ORUB_K_","
IF $LENGTH(ORUB)>225
if XQORM(0)["A"
DO LR^XQORM4
SET ORUER=1
QUIT
+4 SET X=ORUB
+5 QUIT
