- XQORM2 ; SLC/KCM - Lookup for Menu Utility ;11/18/92 15:23
- ;;8.0;KERNEL;**56,62**;Jul 10, 1995
- EN ;From: XQORM Entry: X,XQORM Exit: X,Y,XQORM
- N K K Y,OROTHER I X=" " D Q:'$L(X)
- . I $D(^DISV(DUZ,"XQORM",XQORM,"ALT")),$D(XQORM("ALT")) D S X="" Q
- . . N XQORMERR,XQORMSAV,XQORMRCL
- . . S (X,XQORMSAV)=^DISV(DUZ,"XQORM",XQORM,"ALT"),XQORMRCL=""
- . . X XQORM("ALT") S Y=0
- . . I $D(XQORMERR) S Y=-1 I XQORM(0)["A" W "??" W:XQORM(0)["\" !
- . S XQORM(0)=XQORM(0)_"X" D LAST^XQORM4
- . I '$L(X) S Y=-1 W:XQORM(0)["A" "??" W:XQORM(0)["A"&(XQORM(0)["\") !
- D UP^XQORM1 K ORUX S ORUX=X,(ORUT,ORUER,Y)=0,XQORMSF=""
- F J=1:1:$L(ORUX,",") S X=$P(ORUX,",",J) D EAT,SET D:X["-" RNG^XQORM3 Q:ORUER F K=1:1:$L(X,",") I $L($P(X,",",K)) S ORUT=ORUT+1,ORUX(ORUT)=$P(X,",",K) S:$L(ORUFG) ORUX(ORUT,"=")=ORUFG S:ORUSB ORUX(ORUT,"'")=""
- I 'ORUER S (ORUSQ,ORUT)=0 F I=0:0 S ORUT=$O(ORUX(ORUT)) Q:ORUT="" S X=ORUX(ORUT) D SPCL I $L(X) D LOOK^XQORM3,CHAL Q:ORUER
- I 'ORUER,+XQORM(0),+Y>XQORM(0) D:XQORM(0)["A" NE^XQORM4 S ORUER=1,Y=-1
- I 'ORUER S ORUB=0 F I=0:0 S ORUB=$O(Y(ORUB)) Q:ORUB'>0 D SCRN I 'ORUFG D:ORUX["ALL" SUB I ORUX'["ALL" D:XQORM(0)["A" NS^XQORM4 S ORUER=1
- I 'ORUER,Y>0 W:XQORM(0)["A" " " S ORUFG=$S($X>(IOM-30):9,1:$X) K:XQORM(0)'["F" ^DISV(DUZ,"XQORM",XQORM) F I=0:0 S I=$O(Y(I)) Q:I'>0 D:XQORM(0)["A" ECHO D:XQORM(0)'["F" DISV
- S X=ORUX I ORUER K Y S Y=-1 I $D(XQORM("ALT")) D
- . N XQORMERR,XQORMSAV S XQORMSAV=X X XQORM("ALT")
- . S Y=0 I $D(XQORMERR) S Y=-1 D:XQORM(0)["A" UR^XQORM4
- . I '$D(XQORMERR),(XQORM(0)'["F") D
- . . K ^DISV(DUZ,"XQORM",XQORM)
- . . S ^DISV(DUZ,"XQORM",XQORM,"ALT")=XQORMSAV
- KILL K ORUX,ORUFG,ORUSB,ORUT,ORUER,ORUFD,ORUB,ORUDA,ORUW,ORUSQ,XQORMSF,J,Y("B"),Y("#") Q
- SCRN S ORUFG=1 I $D(XQORM("S"))'[0,$L(XQORM("S")) N DA S DA(1)=+XQORM,DA=+Y(ORUB) I DA N Y X XQORM("S") S ORUFG=$T
- Q
- SET S ORUSB=0 I $E(X)="-",$L(X)>1 S ORUSB=1,X=$P(X,"-",2,99)
- S ORUFG="" I $E(X)'="=" S ORUFG=$P(X,"=",2,99),X=$P(X,"=",1)
- Q
- SPCL S:'$D(XQORSPEW) XQORSPEW=0 I $E(X)="*" S XQORSPEW=$S(XQORSPEW:0,1:1),X=$E(X,2,255) W $S(XQORSPEW:" -RAPID MODE-",1:" -NORMAL MODE-")
- ;I $D(XQORM("KEY",$P(X," "))) S ORUX(ORUT,"=")=$P(X," ",2,99)_"="_$G(ORUX(ORUT,"=")),X="^^`"_XQORM("KEY",$P(X," "))
- I '$D(XQORM("NO^^")),$E(X,1,2)="^^" S Y=Y+1,ORUSQ=ORUSQ+1,Y(ORUSQ)="^"_X,X="" S:$D(ORUX(ORUT,"=")) $P(Y(ORUSQ),"=",2)=ORUX(ORUT,"=") Q
- I XQORM(0)["+","+-"[X S Y=Y+1,ORUSQ=ORUSQ+1,Y(ORUSQ)=X,X="" Q
- I $E(X)=";" D SC^XQORM4 S X="",ORUER=1 Q
- S X=$P(X,";",1) D EAT
- Q
- CHAL ; Q:ORUER I ORUDA,'$D(ORUDA("KEY")),'$D(XQORM("#")) D UPD^XQORM3 Q
- Q:ORUER I ORUDA?1.N1"."1.N D UPD^XQORM3 Q
- I $D(XQORM("KEY",$P(ORUDA," "))) D Q
- . S Y=Y+1,ORUSQ=ORUSQ+1,Y(ORUSQ)="^^"_ORUDA_"^`"_+XQORM("KEY",$P(ORUDA," "))_"="_$P(ORUDA," ",2,99)_"="_$G(ORUX(ORUT,"="))
- . I $P(XQORM("KEY",$P(ORUDA," ")),"^",2) S $P(Y(ORUSQ),"^",2)=+XQORM("KEY",$P(ORUDA," "))
- . K ORUDA("KEY")
- . Q
- I $D(XQORM("#")),ORUDA?1.N,ORUDA D Q
- . I '$D(Y("#")) S Y=Y+1,ORUSQ=ORUSQ+1,Y(ORUSQ)="^"_+XQORM("#")_"^^=",Y("#")=ORUSQ
- . S Y(Y("#"))=Y(Y("#"))_ORUDA_","
- . Q
- I ORUDA="ALL" S X="ALL",ORUER=0 D ALL^XQORM4 Q
- Q
- EAT F I=0:0 Q:$E(X)]" " Q:'$L(X) S X=$E(X,2,999)
- F I=0:0 Q:$E(X,$L(X))]" " Q:'$L(X) S X=$E(X,1,$L(X)-1)
- Q
- ECHO W:($X+$L($P(Y(I),"^",3))+4)>IOM !,?ORUFG W $P(Y(I),"^",3)," " Q
- DISV I +Y(I) S ^DISV(DUZ,"XQORM",XQORM,I)=$P(Y(I),"^",3) Q
- I XQORM(0)["R",$L($P(Y(I),"^",3)) S ^DISV(DUZ,"XQORM",XQORM,I)=$P(Y(I),"^",3) Q
- I XQORM(0)["r",'$L($P(Y(I),"^",3)) S ^DISV(DUZ,"XQORM",XQORM,I)="^^"_$P(Y(I),"^",4)
- Q
- SUB K Y(ORUB) S Y=Y-1 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQORM2 3561 printed Feb 18, 2025@23:32:44 Page 2
- XQORM2 ; SLC/KCM - Lookup for Menu Utility ;11/18/92 15:23
- +1 ;;8.0;KERNEL;**56,62**;Jul 10, 1995
- EN ;From: XQORM Entry: X,XQORM Exit: X,Y,XQORM
- +1 NEW K
- KILL Y,OROTHER
- IF X=" "
- Begin DoDot:1
- +2 IF $DATA(^DISV(DUZ,"XQORM",XQORM,"ALT"))
- IF $DATA(XQORM("ALT"))
- Begin DoDot:2
- +3 NEW XQORMERR,XQORMSAV,XQORMRCL
- +4 SET (X,XQORMSAV)=^DISV(DUZ,"XQORM",XQORM,"ALT")
- SET XQORMRCL=""
- +5 XECUTE XQORM("ALT")
- SET Y=0
- +6 IF $DATA(XQORMERR)
- SET Y=-1
- IF XQORM(0)["A"
- WRITE "??"
- if XQORM(0)["\"
- WRITE !
- End DoDot:2
- SET X=""
- QUIT
- +7 SET XQORM(0)=XQORM(0)_"X"
- DO LAST^XQORM4
- +8 IF '$LENGTH(X)
- SET Y=-1
- if XQORM(0)["A"
- WRITE "??"
- if XQORM(0)["A"&(XQORM(0)["\")
- WRITE !
- End DoDot:1
- if '$LENGTH(X)
- QUIT
- +9 DO UP^XQORM1
- KILL ORUX
- SET ORUX=X
- SET (ORUT,ORUER,Y)=0
- SET XQORMSF=""
- +10 FOR J=1:1:$LENGTH(ORUX,",")
- SET X=$PIECE(ORUX,",",J)
- DO EAT
- DO SET
- if X["-"
- DO RNG^XQORM3
- if ORUER
- QUIT
- FOR K=1:1:$LENGTH(X,",")
- IF $LENGTH($PIECE(X,",",K))
- SET ORUT=ORUT+1
- SET ORUX(ORUT)=$PIECE(X,",",K)
- if $LENGTH(ORUFG)
- SET ORUX(ORUT,"=")=ORUFG
- if ORUSB
- SET ORUX(ORUT,"'")=""
- +11 IF 'ORUER
- SET (ORUSQ,ORUT)=0
- FOR I=0:0
- SET ORUT=$ORDER(ORUX(ORUT))
- if ORUT=""
- QUIT
- SET X=ORUX(ORUT)
- DO SPCL
- IF $LENGTH(X)
- DO LOOK^XQORM3
- DO CHAL
- if ORUER
- QUIT
- +12 IF 'ORUER
- IF +XQORM(0)
- IF +Y>XQORM(0)
- if XQORM(0)["A"
- DO NE^XQORM4
- SET ORUER=1
- SET Y=-1
- +13 IF 'ORUER
- SET ORUB=0
- FOR I=0:0
- SET ORUB=$ORDER(Y(ORUB))
- if ORUB'>0
- QUIT
- DO SCRN
- IF 'ORUFG
- if ORUX["ALL"
- DO SUB
- IF ORUX'["ALL"
- if XQORM(0)["A"
- DO NS^XQORM4
- SET ORUER=1
- +14 IF 'ORUER
- IF Y>0
- if XQORM(0)["A"
- WRITE " "
- SET ORUFG=$SELECT($X>(IOM-30):9,1:$X)
- if XQORM(0)'["F"
- KILL ^DISV(DUZ,"XQORM",XQORM)
- FOR I=0:0
- SET I=$ORDER(Y(I))
- if I'>0
- QUIT
- if XQORM(0)["A"
- DO ECHO
- if XQORM(0)'["F"
- DO DISV
- +15 SET X=ORUX
- IF ORUER
- KILL Y
- SET Y=-1
- IF $DATA(XQORM("ALT"))
- Begin DoDot:1
- +16 NEW XQORMERR,XQORMSAV
- SET XQORMSAV=X
- XECUTE XQORM("ALT")
- +17 SET Y=0
- IF $DATA(XQORMERR)
- SET Y=-1
- if XQORM(0)["A"
- DO UR^XQORM4
- +18 IF '$DATA(XQORMERR)
- IF (XQORM(0)'["F")
- Begin DoDot:2
- +19 KILL ^DISV(DUZ,"XQORM",XQORM)
- +20 SET ^DISV(DUZ,"XQORM",XQORM,"ALT")=XQORMSAV
- End DoDot:2
- End DoDot:1
- KILL KILL ORUX,ORUFG,ORUSB,ORUT,ORUER,ORUFD,ORUB,ORUDA,ORUW,ORUSQ,XQORMSF,J,Y("B"),Y("#")
- QUIT
- SCRN SET ORUFG=1
- IF $DATA(XQORM("S"))'[0
- IF $LENGTH(XQORM("S"))
- NEW DA
- SET DA(1)=+XQORM
- SET DA=+Y(ORUB)
- IF DA
- NEW Y
- XECUTE XQORM("S")
- SET ORUFG=$TEST
- +1 QUIT
- SET SET ORUSB=0
- IF $EXTRACT(X)="-"
- IF $LENGTH(X)>1
- SET ORUSB=1
- SET X=$PIECE(X,"-",2,99)
- +1 SET ORUFG=""
- IF $EXTRACT(X)'="="
- SET ORUFG=$PIECE(X,"=",2,99)
- SET X=$PIECE(X,"=",1)
- +2 QUIT
- SPCL if '$DATA(XQORSPEW)
- SET XQORSPEW=0
- IF $EXTRACT(X)="*"
- SET XQORSPEW=$SELECT(XQORSPEW:0,1:1)
- SET X=$EXTRACT(X,2,255)
- WRITE $SELECT(XQORSPEW:" -RAPID MODE-",1:" -NORMAL MODE-")
- +1 ;I $D(XQORM("KEY",$P(X," "))) S ORUX(ORUT,"=")=$P(X," ",2,99)_"="_$G(ORUX(ORUT,"=")),X="^^`"_XQORM("KEY",$P(X," "))
- +2 IF '$DATA(XQORM("NO^^"))
- IF $EXTRACT(X,1,2)="^^"
- SET Y=Y+1
- SET ORUSQ=ORUSQ+1
- SET Y(ORUSQ)="^"_X
- SET X=""
- if $DATA(ORUX(ORUT,"="))
- SET $PIECE(Y(ORUSQ),"=",2)=ORUX(ORUT,"=")
- QUIT
- +3 IF XQORM(0)["+"
- IF "+-"[X
- SET Y=Y+1
- SET ORUSQ=ORUSQ+1
- SET Y(ORUSQ)=X
- SET X=""
- QUIT
- +4 IF $EXTRACT(X)=";"
- DO SC^XQORM4
- SET X=""
- SET ORUER=1
- QUIT
- +5 SET X=$PIECE(X,";",1)
- DO EAT
- +6 QUIT
- CHAL ; Q:ORUER I ORUDA,'$D(ORUDA("KEY")),'$D(XQORM("#")) D UPD^XQORM3 Q
- +1 if ORUER
- QUIT
- IF ORUDA?1.N1"."1.N
- DO UPD^XQORM3
- QUIT
- +2 IF $DATA(XQORM("KEY",$PIECE(ORUDA," ")))
- Begin DoDot:1
- +3 SET Y=Y+1
- SET ORUSQ=ORUSQ+1
- SET Y(ORUSQ)="^^"_ORUDA_"^`"_+XQORM("KEY",$PIECE(ORUDA," "))_"="_$PIECE(ORUDA," ",2,99)_"="_$GET(ORUX(ORUT,"="))
- +4 IF $PIECE(XQORM("KEY",$PIECE(ORUDA," ")),"^",2)
- SET $PIECE(Y(ORUSQ),"^",2)=+XQORM("KEY",$PIECE(ORUDA," "))
- +5 KILL ORUDA("KEY")
- +6 QUIT
- End DoDot:1
- QUIT
- +7 IF $DATA(XQORM("#"))
- IF ORUDA?1.N
- IF ORUDA
- Begin DoDot:1
- +8 IF '$DATA(Y("#"))
- SET Y=Y+1
- SET ORUSQ=ORUSQ+1
- SET Y(ORUSQ)="^"_+XQORM("#")_"^^="
- SET Y("#")=ORUSQ
- +9 SET Y(Y("#"))=Y(Y("#"))_ORUDA_","
- +10 QUIT
- End DoDot:1
- QUIT
- +11 IF ORUDA="ALL"
- SET X="ALL"
- SET ORUER=0
- DO ALL^XQORM4
- QUIT
- +12 QUIT
- EAT FOR I=0:0
- if $EXTRACT(X)]" "
- QUIT
- if '$LENGTH(X)
- QUIT
- SET X=$EXTRACT(X,2,999)
- +1 FOR I=0:0
- if $EXTRACT(X,$LENGTH(X))]" "
- QUIT
- if '$LENGTH(X)
- QUIT
- SET X=$EXTRACT(X,1,$LENGTH(X)-1)
- +2 QUIT
- ECHO if ($X+$LENGTH($PIECE(Y(I),"^",3))+4)>IOM
- WRITE !,?ORUFG
- WRITE $PIECE(Y(I),"^",3)," "
- QUIT
- DISV IF +Y(I)
- SET ^DISV(DUZ,"XQORM",XQORM,I)=$PIECE(Y(I),"^",3)
- QUIT
- +1 IF XQORM(0)["R"
- IF $LENGTH($PIECE(Y(I),"^",3))
- SET ^DISV(DUZ,"XQORM",XQORM,I)=$PIECE(Y(I),"^",3)
- QUIT
- +2 IF XQORM(0)["r"
- IF '$LENGTH($PIECE(Y(I),"^",3))
- SET ^DISV(DUZ,"XQORM",XQORM,I)="^^"_$PIECE(Y(I),"^",4)
- +3 QUIT
- SUB KILL Y(ORUB)
- SET Y=Y-1
- QUIT