- XQORM3 ; SLC/KCM - Lookup (cont.) ;11/12/92 11:28 [ 04/02/2003 8:29 AM ]
- ;;8.0;KERNEL;**1001,1002,1003,1004,1005,1007**;APR 1, 2003
- ;;8.0;KERNEL;**56,62**;Jul 10, 1995
- 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,$D(XQORM("#")),ORUW?1.12N D Q:ORUDA
- . N X S X=$P(XQORM("#"),"^",2)
- . I X[":" Q:(ORUW<X)!(ORUW>$P(X,":",2))
- . I $L(X),X'[":" Q:(","_X_",")'[(","_ORUW_",")
- . S ORUDA=ORUW
- I 'ORUFD,$L($P(ORUW," ")),(($D(XQORM("KEY",$P(ORUW," ")))&('$D(XQORM("NO^^"))))!(ORUW="ALL")) S ORUDA=ORUW,ORUDA("KEY")="" Q
- I 'ORUFD,$D(XQORM("ALT")) S ORUER=1 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")&(XQORM(0)'["E") 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="" D
- . N J,C S (J,C)=0 F S J=$O(ORUX(J)) Q:'J S C=C+1
- . I C=1 S X="^" W ! ; reprompt if 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.12N1"-"1.12N
- 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
- XQORM3 ; SLC/KCM - Lookup (cont.) ;11/12/92 11:28 [ 04/02/2003 8:29 AM ]
- +1 ;;8.0;KERNEL;**1001,1002,1003,1004,1005,1007**;APR 1, 2003
- +2 ;;8.0;KERNEL;**56,62**;Jul 10, 1995
- 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 $DATA(XQORM("#"))
- IF ORUW?1.12N
- Begin DoDot:1
- +7 NEW X
- SET X=$PIECE(XQORM("#"),"^",2)
- +8 IF X[":"
- IF (ORUW<X)!(ORUW>$PIECE(X,"
- QUIT
- +9 IF $LENGTH(X)
- IF X'[":"
- IF (","_X_",")'[(","_ORUW_",")
- QUIT
- +10 SET ORUDA=ORUW
- End DoDot:1
- IF ORUDA
- QUIT
- +11 IF 'ORUFD
- IF $LENGTH($PIECE(ORUW," "))
- IF (($DATA(XQORM("KEY",$PIECE(ORUW," ")))&('$DATA(XQORM("NO^^"))))!(ORUW="ALL"))
- SET ORUDA=ORUW
- SET ORUDA("KEY")=""
- QUIT
- +12 IF 'ORUFD
- IF $DATA(XQORM("ALT"))
- SET ORUER=1
- QUIT
- +13 IF 'ORUFD
- IF XQORM(0)["A"
- SET ORUER=1
- DO NF^XQORM4
- IF (ORUX[",")!(ORUX["-")
- SET ORUER=0
- DO PICK
- +14 ;S:'ORUFD ORUER=1
- IF ORUFD>1
- DO PICK
- +15 QUIT
- LOOK1 SET ORUFD=ORUFD+1
- SET ORUFD(ORUFD)=ORUDA
- SET ORUDA(ORUDA)=""
- +1 QUIT
- PICK IF (XQORM(0)'["A")&(XQORM(0)'["E")
- 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 IF X=""
- Begin DoDot:1
- +4 NEW J,C
- SET (J,C)=0
- FOR
- SET J=$ORDER(ORUX(J))
- IF 'J
- QUIT
- SET C=C+1
- +5 ; reprompt if 1 selection
- IF C=1
- SET X="^"
- WRITE !
- End DoDot:1
- +6 IF X="^"
- SET ORUER=1
- IF X="^^"
- SET (ORUER,DIROUT)=1
- SET ORUFD=0
- IF ORUER
- QUIT
- +7 IF $LENGTH(X)
- IF $DATA(ORUFD(X))
- SET ORUDA=ORUFD(X)
- SET ORUFD=1
- QUIT
- +8 IF $LENGTH(X)&(X'["^")
- DO LOOK
- +9 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.12N1"-"1.12N
- 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
