- VALMXQ06 ; alb/mjk - XQORD for export with LM v1 ; 3/30/93
- ;;1;List Manager;;Aug 13, 1993
- ;
- ;
- XQORD ; SLC/KCM - Dialog Utility ;11/19/92 08:27
- ;;6.7;Sidewinder;;Jan 08, 1993
- EN D NUL^XQOR2 N DLG,ITM,X ;Process individual prompt
- S DLG=+^TMP("XQORS",$J,XQORS-1,"VPT"),ITM=+^TMP("XQORS",$J,XQORS-1,"ITM",^TMP("XQORS",$J,XQORS-1,"ITM"),"IEN")
- S X=$G(^ORD(101,DLG,10,ITM,1)),X("PRMT")=$P(X,"^",1),X("DFLT")=$P(X,"^",2),X("HELP")=$P(X,"^",3),X("MODE")=$P(X,"^",4)
- S X=$G(^ORD(101,+XQORNOD,101.04)),X("DOM")=$P(X,"^",1),X("PARM")=$P(X,"^",5)
- S:'$L(X("PRMT")) X("PRMT")=$P(X,"^",2) S:'$L(X("DFLT")) X("DFLT")=$P(X,"^",3) S:'$L(X("HELP")) X("HELP")=$P(X,"^",4)
- S XQORDLG(ITM,"PRMT")=X("PRMT")_"^"_X("MODE"),XQORDLG("SEQ",+^TMP("XQORS",$J,XQORS-1,"ITM"))=ITM
- I X("MODE")["E",$D(XQORMSG),XQORMSG="NEW" D G XEN
- . I '$D(XQORDLG(ITM,1)),$L(X("DFLT")) S XQORDLG(ITM,1,"I")="",XQORDLG(ITM,1,"E")=X("DFLT")
- ;
- ; -- case prompt type (X("DOM"))
- I "DFLNPSY"[X("DOM") D RDR^XQORD1 G C1
- I X("DOM")="W" D WP^XQORD1 G C1
- I X("DOM")="M" D MENU^XQORD1 G C1
- C1 ; -- end case prompt type
- ;
- ; -- case up-arrow status (X)
- I $E(X)'="^" D SETANS G C2 ;valid entry
- S X=$P(X,"^",2) I '$L(X) S XQORPOP=1,XQORDLG=-1 G C2 ;up arrow out
- I $D(^TMP("XQORS",$J,XQORS-1,"PMT",$$UP(X))) S ^TMP("XQORS",$J,XQORS-1,"ITM")=$O(^($$UP(X),0))-1 G C2 ;full name jump
- S Y=$O(^TMP("XQORS",$J,XQORS-1,"PMT",$$UP(X))) ;partial name jump
- I $E(Y,1,$L(X))=$$UP(X) S ^TMP("XQORS",$J,XQORS-1,"ITM")=$O(^TMP("XQORS",$J,XQORS-1,"PMT",Y,0))-1 G C2
- W " ??" S ^TMP("XQORS",$J,XQORS-1,"ITM")=^TMP("XQORS",$J,XQORS-1,"ITM")-1 ;otherwise...
- C2 ; -- end case up-arrow status
- ;
- XEN Q ;Exit: XQORDLG(n)=external value of response
- ;
- SETANS ;Setup answers in array according to type, calling info in X,Y
- ;Entry: .X is external value, .Y is internal value, X("DOM") is prompt type
- S XQORDLG(ITM)=""
- I $L(Y) DO
- . ; -- case prompt type (X("DOM"))
- . I X("DOM")="D" D DD^%DT S XQORDLG(ITM)=Y G C3 ;date/Time
- . I X("DOM")="F" S XQORDLG(ITM)=Y G C3 ;free Text
- . I X("DOM")="L" S XQORDLG(ITM)=X G C3 ;list/Range
- . I X("DOM")="N" S XQORDLG(ITM)=Y G C3 ;numeric
- . I X("DOM")="P" S XQORDLG(ITM)=$P(Y,"^",2) G C3 ;pointer
- . I X("DOM")="S" S XQORDLG(ITM)=Y(0) G C3 ;set
- . I X("DOM")="Y" S XQORDLG(ITM)=$S(Y=0:"NO",Y=1:"YES",1:"") G C3 ;yes/no
- . I X("DOM")="W" S XQORDLG(ITM)=Y G C3 ;word processing
- . I X("DOM")="M" DO G C3 ;menu
- . . N I S I=0 F S I=$O(Y(I)) Q:I<1 DO
- . . . S XQORDLG(ITM)=$P(Y(I),"^",3)_","
- . . S XQORDLG(ITM)=$E(XQORDLG(ITM),1,$L(XQORDLG(ITM))-1)
- C3 . ; -- end case prompt type
- . ;
- Q
- UP(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVALMXQ06 2696 printed Feb 18, 2025@23:36:47 Page 2
- VALMXQ06 ; alb/mjk - XQORD for export with LM v1 ; 3/30/93
- +1 ;;1;List Manager;;Aug 13, 1993
- +2 ;
- +3 ;
- XQORD ; SLC/KCM - Dialog Utility ;11/19/92 08:27
- +1 ;;6.7;Sidewinder;;Jan 08, 1993
- EN ;Process individual prompt
- DO NUL^XQOR2
- NEW DLG,ITM,X
- +1 SET DLG=+^TMP("XQORS",$JOB,XQORS-1,"VPT")
- SET ITM=+^TMP("XQORS",$JOB,XQORS-1,"ITM",^TMP("XQORS",$JOB,XQORS-1,"ITM"),"IEN")
- +2 SET X=$GET(^ORD(101,DLG,10,ITM,1))
- SET X("PRMT")=$PIECE(X,"^",1)
- SET X("DFLT")=$PIECE(X,"^",2)
- SET X("HELP")=$PIECE(X,"^",3)
- SET X("MODE")=$PIECE(X,"^",4)
- +3 SET X=$GET(^ORD(101,+XQORNOD,101.04))
- SET X("DOM")=$PIECE(X,"^",1)
- SET X("PARM")=$PIECE(X,"^",5)
- +4 if '$LENGTH(X("PRMT"))
- SET X("PRMT")=$PIECE(X,"^",2)
- if '$LENGTH(X("DFLT"))
- SET X("DFLT")=$PIECE(X,"^",3)
- if '$LENGTH(X("HELP"))
- SET X("HELP")=$PIECE(X,"^",4)
- +5 SET XQORDLG(ITM,"PRMT")=X("PRMT")_"^"_X("MODE")
- SET XQORDLG("SEQ",+^TMP("XQORS",$JOB,XQORS-1,"ITM"))=ITM
- +6 IF X("MODE")["E"
- IF $DATA(XQORMSG)
- IF XQORMSG="NEW"
- Begin DoDot:1
- +7 IF '$DATA(XQORDLG(ITM,1))
- IF $LENGTH(X("DFLT"))
- SET XQORDLG(ITM,1,"I")=""
- SET XQORDLG(ITM,1,"E")=X("DFLT")
- End DoDot:1
- GOTO XEN
- +8 ;
- +9 ; -- case prompt type (X("DOM"))
- +10 IF "DFLNPSY"[X("DOM")
- DO RDR^XQORD1
- GOTO C1
- +11 IF X("DOM")="W"
- DO WP^XQORD1
- GOTO C1
- +12 IF X("DOM")="M"
- DO MENU^XQORD1
- GOTO C1
- C1 ; -- end case prompt type
- +1 ;
- +2 ; -- case up-arrow status (X)
- +3 ;valid entry
- IF $EXTRACT(X)'="^"
- DO SETANS
- GOTO C2
- +4 ;up arrow out
- SET X=$PIECE(X,"^",2)
- IF '$LENGTH(X)
- SET XQORPOP=1
- SET XQORDLG=-1
- GOTO C2
- +5 ;full name jump
- IF $DATA(^TMP("XQORS",$JOB,XQORS-1,"PMT",$$UP(X)))
- SET ^TMP("XQORS",$JOB,XQORS-1,"ITM")=$ORDER(^($$UP(X),0))-1
- GOTO C2
- +6 ;partial name jump
- SET Y=$ORDER(^TMP("XQORS",$JOB,XQORS-1,"PMT",$$UP(X)))
- +7 IF $EXTRACT(Y,1,$LENGTH(X))=$$UP(X)
- SET ^TMP("XQORS",$JOB,XQORS-1,"ITM")=$ORDER(^TMP("XQORS",$JOB,XQORS-1,"PMT",Y,0))-1
- GOTO C2
- +8 ;otherwise...
- WRITE " ??"
- SET ^TMP("XQORS",$JOB,XQORS-1,"ITM")=^TMP("XQORS",$JOB,XQORS-1,"ITM")-1
- C2 ; -- end case up-arrow status
- +1 ;
- XEN ;Exit: XQORDLG(n)=external value of response
- QUIT
- +1 ;
- SETANS ;Setup answers in array according to type, calling info in X,Y
- +1 ;Entry: .X is external value, .Y is internal value, X("DOM") is prompt type
- +2 SET XQORDLG(ITM)=""
- +3 IF $LENGTH(Y)
- Begin DoDot:1
- +4 ; -- case prompt type (X("DOM"))
- +5 ;date/Time
- IF X("DOM")="D"
- DO DD^%DT
- SET XQORDLG(ITM)=Y
- GOTO C3
- +6 ;free Text
- IF X("DOM")="F"
- SET XQORDLG(ITM)=Y
- GOTO C3
- +7 ;list/Range
- IF X("DOM")="L"
- SET XQORDLG(ITM)=X
- GOTO C3
- +8 ;numeric
- IF X("DOM")="N"
- SET XQORDLG(ITM)=Y
- GOTO C3
- +9 ;pointer
- IF X("DOM")="P"
- SET XQORDLG(ITM)=$PIECE(Y,"^",2)
- GOTO C3
- +10 ;set
- IF X("DOM")="S"
- SET XQORDLG(ITM)=Y(0)
- GOTO C3
- +11 ;yes/no
- IF X("DOM")="Y"
- SET XQORDLG(ITM)=$SELECT(Y=0:"NO",Y=1:"YES",1:"")
- GOTO C3
- +12 ;word processing
- IF X("DOM")="W"
- SET XQORDLG(ITM)=Y
- GOTO C3
- +13 ;menu
- IF X("DOM")="M"
- Begin DoDot:2
- +14 NEW I
- SET I=0
- FOR
- SET I=$ORDER(Y(I))
- if I<1
- QUIT
- Begin DoDot:3
- +15 SET XQORDLG(ITM)=$PIECE(Y(I),"^",3)_","
- End DoDot:3
- +16 SET XQORDLG(ITM)=$EXTRACT(XQORDLG(ITM),1,$LENGTH(XQORDLG(ITM))-1)
- End DoDot:2
- GOTO C3
- C3 ; -- end case prompt type
- +1 ;
- End DoDot:1
- +2 QUIT
- UP(X) QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")