PRSU1A ;WOIFO/PLT-General Questions Utility ; 24-Aug-2005 10:34 AM
;;4.0;PAID;**126**;Sep 21, 1995;Build 59
;;Per VHA Directive 2004-038, this routine should not be modified.
QUIT ;invalid entry
;the followoings are DIR calls for data type D,E,F,L,N,P,S,Y,#,#
; D-date, E-end of page, F-free-text, L-list or range, N-numeric
; P- pointer, S-set of codes, Y-yes/no, #,#- dd data dictionary
;A for DIR("A") - prompt text.
;B for DIR(0) 2nd character to end - input modifiers^[parameters]^[transform.]
; modifiers A: prompt not appended, O: response optional
; r: no replace-with for the defalut response
; set of codes B: code listed horizontally, X: exact match
; free text U: if '^' allowed in free text
; list or range C: compress y array, not y-array returned
;C for DIR("B") - default response
;.x(1...) for DIR("A") prompt array or value returned
;.y(1...) for DIR("?") array or value returned
;
;date
;B is ^1=A,O or "", ^2=mini date:maximum date, ^3=mumps code
DT(X,Y,A,B,C) N DIR,D S DIR(0)="D"_B,DIR("A")=A S:$G(C)]"" DIR("B")=C
S DIR("?")="Enter a date",D=$P(B,U,2,3)
I $P(D,":")]"" S Y=$P(D,":") D DD^%DT S Y=$S($P(D,":",2)]"":" between ",1:" after ")_Y,DIR("?")=DIR("?")_Y
I $P(D,":",2)]"" S Y=$P(B,":",2) D DD^%DT S Y=$S($P(D,":",1)="":" before ",1:" and ")_Y,DIR("?")=DIR("?")_Y
D DIRA:$D(X(1)),DIRQ:$D(Y(1)),^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S Y="^" K DTOUT,DUOUT,DIROUT
QUIT
;
;end of page
;B is ^1= A or "", ^2="", ^3=""
EOP(X,Y,A,B,C) N DIR S DIR(0)="E"_B S:A]"" DIR("A")=A S:$G(C)]"" DIR("B")=C
S DIR("?")="Enter 'return' to continue or '^' to exit."
D DIRA:$D(X(1)),DIRQ:$D(Y(1)),^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S Y="^" K DTOUT,DUOUT,DIROUT
QUIT
;
;free text
;B is ^1=A,O,U, ^2=minimum legth:maximum length, ^3=mumps code
FT(X,Y,A,B,C) N DIR S DIR(0)="F"_B S:A]"" DIR("A")=A S:$G(C)]"" DIR("B")=C
D DIRA:$D(X(1)),DIRQ:$D(Y(1)),^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S Y="^" K DTOUT,DUOUT,DIROUT
QUIT
;
;list of range
;B is ^1=A,O or "", ^2=mini value:maxi value, ^3=mumps code
LR(X,Y,A,B,C) N DIR S DIR(0)="L"_B S:A]"" DIR("A")=A S:$G(C)]"" DIR("B")=C
D DIRA:$D(X(1)),DIRQ:$D(Y(1)),^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S Y="^" K DTOUT,DUOUT,DIROUT
QUIT
;
;numeric
;B is ^1=A,O or "", ^2=mini value:maxi value:maxi decimals, ^3=mumps code
NUM(X,Y,A,B,C) N DIR S DIR(0)="N"_B S:A]"" DIR("A")=A S:$G(C)]"" DIR("B")=C
D DIRA:$D(X(1)),DIRQ:$D(Y(1)),^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S Y="^" K DTOUT,DUOUT,DIROUT
QUIT
;
;pointer
;B is ^1=A,O or "", ^2=file #/subfile root:dic(0) data, ^3=mumps code
PTR(X,Y,A,B,C) N DIR S DIR(0)="P"_B S:A]"" DIR("A")=A S:$G(C)]"" DIR("B")=C
D DIRA:$D(X(1)),DIRQ:$D(Y(1)),^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S Y="^" K DTOUT,DUOUT,DIROUT
QUIT
;
;set of codes
;B is ^1=A,O,X,B, or M, ^2=code:description;code:description;..., ^3=mumps code
SC(X,Y,A,B,C) N DIR S DIR(0)="S"_B S:A]"" DIR("A")=A S:$G(C)]"" DIR("B")=C
D DIRA:$D(X(1)),DIRQ:$D(Y(1)),^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S Y="^" K DTOUT,DUOUT,DIROUT
QUIT
;
;yes/no
;B is ^1=A,O or "", ^2="", ^3=""
YN(X,Y,A,B,C) N DIR S DIR(0)="Y"_B S:A]"" DIR("A")=A S:$G(C)]"" DIR("B")=C
S DIR("?")="Enter 'Y' for yes, 'N' for no."
D DIRA:$D(X(1)),DIRQ:$D(Y(1)),^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S Y="^" K DTOUT,DUOUT,DIROUT
QUIT
;
;data field definition
;B is ^1=(sub)file number,field numberAO, ^2="", ^3=""
DD(X,Y,A,B,C) N DIR S DIR(0)=B S:A]"" DIR("A")=A S:$G(C)]"" DIR("B")=C
D DIRA:$D(X(1)),DIRQ:$D(Y(1)),^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S Y="^" K DTOUT,DUOUT,DIROUT
QUIT
;
DIRA N A S A=0 F S A=$O(X(A)) Q:A="" S DIR("A",A)=X(A)
K X
QUIT
DIRQ N A F A=1:1 Q:'$D(Y(A)) S DIR("?",A)=Y(A)
S DIR("?")=Y(A-1) K DIR("?",A-1)
K Y
QUIT
;
;.x user typed value
;.y=-1 if invalid, cyymmdd.hhmmss
;A=prompt text
;B=^1:default value (external form), ^2=[-]fm date, [before]after date
;C=string of AEFNPRST, any combination
; A for ask, E for echo
; F for future assumed, N for pure num not allowed
; P for past assumed, R time required
; S seconds required, T time is optional
;D= Y if year only, YM if year and month only, YMD if date[@time] only
YMDT(X,Y,A,B,C,D) ;reader for year/month/date/time
N %DT,DTOUT
YMDT1 S %DT("A")=A,%DT("B")=$P(B,"^") S:$P(B,"^",2)]"" %DT(0)=$P(B,"^",2)
S %DT=C S:$G(D)="YMD" %DT=%DT_"X"
D ^%DT
I Y'=-1,$G(D)="Y",Y#10000'=0 W " Enter year only!" G YMDT1
I Y'=-1,$G(D)="YM",Y#100'=0 W " Enter month and year only!" G YMDT1
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSU1A 4594 printed Oct 16, 2024@18:29:26 Page 2
PRSU1A ;WOIFO/PLT-General Questions Utility ; 24-Aug-2005 10:34 AM
+1 ;;4.0;PAID;**126**;Sep 21, 1995;Build 59
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;invalid entry
QUIT
+4 ;the followoings are DIR calls for data type D,E,F,L,N,P,S,Y,#,#
+5 ; D-date, E-end of page, F-free-text, L-list or range, N-numeric
+6 ; P- pointer, S-set of codes, Y-yes/no, #,#- dd data dictionary
+7 ;A for DIR("A") - prompt text.
+8 ;B for DIR(0) 2nd character to end - input modifiers^[parameters]^[transform.]
+9 ; modifiers A: prompt not appended, O: response optional
+10 ; r: no replace-with for the defalut response
+11 ; set of codes B: code listed horizontally, X: exact match
+12 ; free text U: if '^' allowed in free text
+13 ; list or range C: compress y array, not y-array returned
+14 ;C for DIR("B") - default response
+15 ;.x(1...) for DIR("A") prompt array or value returned
+16 ;.y(1...) for DIR("?") array or value returned
+17 ;
+18 ;date
+19 ;B is ^1=A,O or "", ^2=mini date:maximum date, ^3=mumps code
DT(X,Y,A,B,C) NEW DIR,D
SET DIR(0)="D"_B
SET DIR("A")=A
if $GET(C)]""
SET DIR("B")=C
+1 SET DIR("?")="Enter a date"
SET D=$PIECE(B,U,2,3)
+2 IF $PIECE(D,":")]""
SET Y=$PIECE(D,":")
DO DD^%DT
SET Y=$SELECT($PIECE(D,":",2)]"":" between ",1:" after ")_Y
SET DIR("?")=DIR("?")_Y
+3 IF $PIECE(D,":",2)]""
SET Y=$PIECE(B,":",2)
DO DD^%DT
SET Y=$SELECT($PIECE(D,":",1)="":" before ",1:" and ")_Y
SET DIR("?")=DIR("?")_Y
+4 if $DATA(X(1))
DO DIRA
if $DATA(Y(1))
DO DIRQ
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET Y="^"
KILL DTOUT,DUOUT,DIROUT
+5 QUIT
+6 ;
+7 ;end of page
+8 ;B is ^1= A or "", ^2="", ^3=""
EOP(X,Y,A,B,C) NEW DIR
SET DIR(0)="E"_B
if A]""
SET DIR("A")=A
if $GET(C)]""
SET DIR("B")=C
+1 SET DIR("?")="Enter 'return' to continue or '^' to exit."
+2 if $DATA(X(1))
DO DIRA
if $DATA(Y(1))
DO DIRQ
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET Y="^"
KILL DTOUT,DUOUT,DIROUT
+3 QUIT
+4 ;
+5 ;free text
+6 ;B is ^1=A,O,U, ^2=minimum legth:maximum length, ^3=mumps code
FT(X,Y,A,B,C) NEW DIR
SET DIR(0)="F"_B
if A]""
SET DIR("A")=A
if $GET(C)]""
SET DIR("B")=C
+1 if $DATA(X(1))
DO DIRA
if $DATA(Y(1))
DO DIRQ
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET Y="^"
KILL DTOUT,DUOUT,DIROUT
+2 QUIT
+3 ;
+4 ;list of range
+5 ;B is ^1=A,O or "", ^2=mini value:maxi value, ^3=mumps code
LR(X,Y,A,B,C) NEW DIR
SET DIR(0)="L"_B
if A]""
SET DIR("A")=A
if $GET(C)]""
SET DIR("B")=C
+1 if $DATA(X(1))
DO DIRA
if $DATA(Y(1))
DO DIRQ
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET Y="^"
KILL DTOUT,DUOUT,DIROUT
+2 QUIT
+3 ;
+4 ;numeric
+5 ;B is ^1=A,O or "", ^2=mini value:maxi value:maxi decimals, ^3=mumps code
NUM(X,Y,A,B,C) NEW DIR
SET DIR(0)="N"_B
if A]""
SET DIR("A")=A
if $GET(C)]""
SET DIR("B")=C
+1 if $DATA(X(1))
DO DIRA
if $DATA(Y(1))
DO DIRQ
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET Y="^"
KILL DTOUT,DUOUT,DIROUT
+2 QUIT
+3 ;
+4 ;pointer
+5 ;B is ^1=A,O or "", ^2=file #/subfile root:dic(0) data, ^3=mumps code
PTR(X,Y,A,B,C) NEW DIR
SET DIR(0)="P"_B
if A]""
SET DIR("A")=A
if $GET(C)]""
SET DIR("B")=C
+1 if $DATA(X(1))
DO DIRA
if $DATA(Y(1))
DO DIRQ
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET Y="^"
KILL DTOUT,DUOUT,DIROUT
+2 QUIT
+3 ;
+4 ;set of codes
+5 ;B is ^1=A,O,X,B, or M, ^2=code:description;code:description;..., ^3=mumps code
SC(X,Y,A,B,C) NEW DIR
SET DIR(0)="S"_B
if A]""
SET DIR("A")=A
if $GET(C)]""
SET DIR("B")=C
+1 if $DATA(X(1))
DO DIRA
if $DATA(Y(1))
DO DIRQ
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET Y="^"
KILL DTOUT,DUOUT,DIROUT
+2 QUIT
+3 ;
+4 ;yes/no
+5 ;B is ^1=A,O or "", ^2="", ^3=""
YN(X,Y,A,B,C) NEW DIR
SET DIR(0)="Y"_B
if A]""
SET DIR("A")=A
if $GET(C)]""
SET DIR("B")=C
+1 SET DIR("?")="Enter 'Y' for yes, 'N' for no."
+2 if $DATA(X(1))
DO DIRA
if $DATA(Y(1))
DO DIRQ
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET Y="^"
KILL DTOUT,DUOUT,DIROUT
+3 QUIT
+4 ;
+5 ;data field definition
+6 ;B is ^1=(sub)file number,field numberAO, ^2="", ^3=""
DD(X,Y,A,B,C) NEW DIR
SET DIR(0)=B
if A]""
SET DIR("A")=A
if $GET(C)]""
SET DIR("B")=C
+1 if $DATA(X(1))
DO DIRA
if $DATA(Y(1))
DO DIRQ
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
SET Y="^"
KILL DTOUT,DUOUT,DIROUT
+2 QUIT
+3 ;
DIRA NEW A
SET A=0
FOR
SET A=$ORDER(X(A))
if A=""
QUIT
SET DIR("A",A)=X(A)
+1 KILL X
+2 QUIT
DIRQ NEW A
FOR A=1:1
if '$DATA(Y(A))
QUIT
SET DIR("?",A)=Y(A)
+1 SET DIR("?")=Y(A-1)
KILL DIR("?",A-1)
+2 KILL Y
+3 QUIT
+4 ;
+5 ;.x user typed value
+6 ;.y=-1 if invalid, cyymmdd.hhmmss
+7 ;A=prompt text
+8 ;B=^1:default value (external form), ^2=[-]fm date, [before]after date
+9 ;C=string of AEFNPRST, any combination
+10 ; A for ask, E for echo
+11 ; F for future assumed, N for pure num not allowed
+12 ; P for past assumed, R time required
+13 ; S seconds required, T time is optional
+14 ;D= Y if year only, YM if year and month only, YMD if date[@time] only
YMDT(X,Y,A,B,C,D) ;reader for year/month/date/time
+1 NEW %DT,DTOUT
YMDT1 SET %DT("A")=A
SET %DT("B")=$PIECE(B,"^")
if $PIECE(B,"^",2)]""
SET %DT(0)=$PIECE(B,"^",2)
+1 SET %DT=C
if $GET(D)="YMD"
SET %DT=%DT_"X"
+2 DO ^%DT
+3 IF Y'=-1
IF $GET(D)="Y"
IF Y#10000'=0
WRITE " Enter year only!"
GOTO YMDT1
+4 IF Y'=-1
IF $GET(D)="YM"
IF Y#100'=0
WRITE " Enter month and year only!"
GOTO YMDT1
+5 QUIT
