- DIR2 ;SFISC/XAK - READER (SETUP VARS,REPLACE...WITH) ;2DEC2016
- ;;22.2;VA FileMan;**2,5,8**;Jan 05, 2016;Build 19
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;CALLED FROM THE TOP OF THE READER (DIR) %P WILL NOT BE DEFINED.
- K Y,% S U="^"
- D ;p8
- .N DINAKED S DINAKED=$$LGR^%ZOSV
- .D DIR("A"),DIR("?"),DIR("L"),DIR("B")
- .I DINAKED]"" S DINAKED=$S(DINAKED["""""":$O(@DINAKED),1:$D(@DINAKED))
- .Q
- S %T=$E(DIR(0)),%A=$P(DIR(0),U),%B=$P(DIR(0),U,2),%N=%A'["V"
- K:$D(DIR("A"))=10 DIR("A") K:$D(DIR("?"))=10 DIR("?")
- S %W0=$S($D(DIR("?")):DIR("?"),%T'?.AN:"",'$P($T(@(%T_1)),";",5):"",1:$$EZBLD^DIALOG($P($T(@(%T_1)),";",5)))
- S %A0=$$EZBLD^DIALOG(8041) ;'REQUIRED RESPONSE'
- FIELD I %A?.NP1",".ANP S %B1=$P(%A,","),%B2=+$P(%A,",",2) D G EO:'$D(%A),NN ;SPECIFICATION OF READ IS 'DATA DICTIONARY', SO GET FIELD PROPERTIES
- .I '$D(^DD(%B1,%B2,0)) K %A Q
- .S %B3=^(0),%B=$P(%B3,U,2) I %B["C"!%B K %A Q ;%B IS USED LATER, IN DIR1 ROUTINE
- .D:'$D(DIR("B")) DA^DIRQ:$D(DA)#2
- .S:'$D(DIR("A")) %P=$$LABEL^DIALOGZ(%B1,%B2)_": " S:$P(%B3,U,2)'["R" %A=%A_"O"
- .S %T=1 ;IN DIR1, "1"=DATA DICTIONARY
- .N I S I=+$P(%B,"t",2),I=$P($G(^DI(.81,I,0)),U,2) I I="S" S I=$$GETPROP^DIETLIBF(%B1,%B2,"SET OF CODES") D:I]"" S0(I):%A'["A" ;if this a user-defined data type read
- I "FSYENDLP"'[%T G EO
- S %B1=$P(%B,":"),%B2=$P(%B,":",2),%B3=$P(%B,":",3)
- S:'$L(%B2) %B2=$S(%T="D":9991231,%T="F":245,1:999999999999)
- I %T="F",%B2>245 S %B2=245
- I %T="Y" S %B=$$EZBLD^DIALOG(7003)
- I %T="D" S %DT=$P(%B3,"A")_$P(%B3,"A",2)
- I %T="D",'$D(DIR("?")) S %W0=%W0_$S(%B3["R":$$EZBLD^DIALOG(8043),%B3["T":$$EZBLD^DIALOG(8044),1:"")
- I %T="D" S %D1=%B1,%D2=%B2 I %B["NOW"!(%B["DT") D NOW^%DTC K %I,%H S DT=X S:%B1["NOW" %B1=% S:%B1["DT" %B1=X S:%B2["NOW" %B2=% S:%B2["DT" %B2=X K %
- I %T="P" S %B1=$S('%B1:U_%B1,'$D(^DIC(+%B1,0,"GL")):U,1:^("GL")) G EO:%B1=U,EO:'$D(@(%B1_"0)")) I '$D(DIR("A")) S %P=$$EZBLD^DIALOG(8042,$O(^DD(+$P(^(0),U,2),0,"NM",0))) Q
- NN I %T="S" D S0(%B):%A'["A"
- Q:$D(%P)
- S %P="" I %A["A" S:$D(DIR("A")) %P=DIR("A") Q
- I '$D(DIR("A")) S %P=$$EZBLD^DIALOG($P($T(@%T),";",4)) I %T="D" S %P=%P_$S(%B3["R":$$EZBLD^DIALOG(8043),%B3["T":$$EZBLD^DIALOG(8044),1:"")
- S:$D(DIR("A")) %P=$S(%T="Y":DIR("A")_"? ",%T="S":$$EZBLD^DIALOG(8045,DIR("A")),1:DIR("A")_": ")
- I "LND"'[%T Q ;'LIST', 'NUMERIC', 'DATE' types
- I $L(%B1) S %P=%P_" ("_$S(%T="D":$$DATE^DIUTL(%B1)_"-"_$$DATE^DIUTL(%B2),1:%B1_"-"_%B2)_")" ;**
- S %P=%P_$S("?: "[$E(%P,$L(%P)):"",1:":")_" "
- Q
- ;
- ;
- S0(%B) ;CREATE PROMPT FOR READING A 'SET' TYPE. %B is the SET OF CODES
- I '$D(%P) S %P=$S($D(DIR("A")):DIR("A")_": ",%A["B":$$EZBLD^DIALOG(8046),1:$$EZBLD^DIALOG($P($T(S),";",4)))
- Q:%A'["B" ;"B" PARAMETER SHOWS THE CHOICES SEPARATED BY "/"S
- S %P=%P_" ("
- I %B'[":",$O(DIR("C",""))]"" S %I="" F S %I=$O(DIR("C",%I)) Q:%I="" D
- . N Y S Y=$P(DIR("C",%I),":") Q:Y=""
- . I $D(DIR("S"))#2 X DIR("S") E Q
- . S %P=%P_Y_"/"
- E F %I=1:1 Q:$P(%B,";",%I,999)="" D
- . N Y S Y=$P($P(%B,";",%I),":") Q:Y=""
- . I $D(DIR("S"))#2 X DIR("S") E Q
- . S %P=%P_Y_"/"
- S %P=$E(%P,1,$L(%P)-(%P?.E1"/"))_"): "
- Q
- ;
- ;
- EO S %T="",Y=-1 Q ;ABORT
- ;
- DIR(DIALA) ;** INSERTS DIALOGS INTO DIR ARRAY
- N DIALN,DIALP
- S DIALN=$G(DIR("DIALOG",DIALA))
- Q:'$D(^DI(.84,0)) Q:+DIALN'=DIALN Q:'$D(^(DIALN,2)) ;GIVES US A MAKED REFERENCE PRIOR TO CALLING $$EZBLD^DIALOG
- I $D(DIR("DIALOG",DIALA))>9 M DIALP=DIR("DIALOG",DIALA)
- K DIR(DIALA) D BLD^DIALOG(DIALN,.DIALP,,"DIR(DIALA)","F")
- Q
- ;
- ;
- RW ; Replace...With... ENTER WITH 'Y', EXIT WITH 'Y' CHANGED. CALLED FROM MANY ROUTINES
- N %,L,DINAKED S DINAKED=$NA(^(0)),DG=Y S:$D(DTIME)[0 DTIME=999
- A W:$X>50 ! K DTOUT W $$EZBLD^DIALOG(8047) R X:DTIME E S DTOUT=1,X=""
- G B:X="",Q:X?1."^",Q:$E(X)=U&($D(DIRWP)[0)&(Y'[X),Q:X?."?",Q:X="@"
- I X="END"!(X="end")!(X=$$UP^DILIBF($$EZBLD^DIALOG(7097))) S L=0 D H S:'%&'$D(DTOUT) Y=Y_X G A ;**CCO/NI 'END'
- I Y[X S D=X,L=$L(X) D H S:'%&'$D(DTOUT) Y=$P(Y,D,1)_X_$P(Y,D,2,999) G A
- S D=$P(X,"...",1),DH=$F(Y,D) I DH S X=$P(X,"...",2,99),X=$S(X="":$L(Y)+1,1:$F(Y,X,DH)) I X S DH=DH-$L(D)-1,D=X,L=D-DH-1 D H S:'%&'$D(DTOUT) Y=$E(Y,1,DH)_X_$E(Y,D,999) G A
- W $C(7)," ??" G A
- ;
- H N DIMAX
- WITH W $$EZBLD^DIALOG(8048) R X:DTIME E S DTOUT=1,X="",%=0 W $C(7)," ??" Q
- S DIMAX=$G(^DD("STRING_LIMIT"),255)-10,%=$L(Y)-L+$L(X)>DIMAX
- I % W $C(7),$S($L(Y)-L'>DIMAX:$$EZBLD^DIALOG(349,($L(Y)-L+$L(X)-DIMAX)),X'=U:$$EZBLD^DIALOG(350),1:" ??") Q:$L(Y)-L>DIMAX&(X=U) G WITH
- Q:X?.ANP W $C(7)," ??" G WITH
- ;
- B W:$D(DTOUT) $C(7) I DG'=Y S X=Y W !?3 W X I X="" S X="@"
- S:DINAKED]"" DINAKED=$S(DINAKED["""""":$O(@DINAKED),1:$D(@DINAKED)) ;p8
- Q Q
- ;
- F ;;Enter response: ;8051
- S ;;Enter response: ;8051
- Y ;;Enter Yes or No: ;8052
- E ;;Press RETURN to continue or '^' to exit: ;8053
- N ;;Enter a number;8054
- D ;;Enter a date;8055
- L ;;Enter a list or range of numbers;8056
- P ;;Select: ;8057
- F1 ;;;This response can be free text;9031
- S1 ;;;Enter a code from the list.;9032
- Y1 ;;;Enter either 'Y' or 'N'.;9040
- E1 ;;;Enter either RETURN or '^';9033
- N1 ;;;This response must be a number;9034
- D1 ;;;This response must be a date;9035
- L1 ;;;This response must be a list or range, e.g., 1,3,5 or 2-4,8;9036
- ;
- ;#349 String too long by |nuber| character(s)!
- ;#350 String too long! '^' to quit.
- ;#8041 This is a required response...
- ;#8042 Select |1|
- ;#8043 and time
- ;#8044 and optional time
- ;#8045 Enter |1|
- ;#8046 Select one of the following
- ;#8047 Replace
- ;#8048 With
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIR2 5702 printed Mar 13, 2025@21:58:45 Page 2
- DIR2 ;SFISC/XAK - READER (SETUP VARS,REPLACE...WITH) ;2DEC2016
- +1 ;;22.2;VA FileMan;**2,5,8**;Jan 05, 2016;Build 19
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;CALLED FROM THE TOP OF THE READER (DIR) %P WILL NOT BE DEFINED.
- +7 KILL Y,%
- SET U="^"
- +8 ;p8
- Begin DoDot:1
- +9 NEW DINAKED
- SET DINAKED=$$LGR^%ZOSV
- +10 DO DIR("A")
- DO DIR("?")
- DO DIR("L")
- DO DIR("B")
- +11 IF DINAKED]""
- SET DINAKED=$SELECT(DINAKED["""""":$ORDER(@DINAKED),1:$DATA(@DINAKED))
- +12 QUIT
- End DoDot:1
- +13 SET %T=$EXTRACT(DIR(0))
- SET %A=$PIECE(DIR(0),U)
- SET %B=$PIECE(DIR(0),U,2)
- SET %N=%A'["V"
- +14 if $DATA(DIR("A"))=10
- KILL DIR("A")
- if $DATA(DIR("?"))=10
- KILL DIR("?")
- +15 SET %W0=$SELECT($DATA(DIR("?")):DIR("?"),%T'?.AN:"",'$PIECE($TEXT(@(%T_1)),";",5):"",1:$$EZBLD^DIALOG($PIECE($TEXT(@(%T_1)),";",5)))
- +16 ;'REQUIRED RESPONSE'
- SET %A0=$$EZBLD^DIALOG(8041)
- FIELD ;SPECIFICATION OF READ IS 'DATA DICTIONARY', SO GET FIELD PROPERTIES
- IF %A?.NP1",".ANP
- SET %B1=$PIECE(%A,",")
- SET %B2=+$PIECE(%A,",",2)
- Begin DoDot:1
- +1 IF '$DATA(^DD(%B1,%B2,0))
- KILL %A
- QUIT
- +2 ;%B IS USED LATER, IN DIR1 ROUTINE
- SET %B3=^(0)
- SET %B=$PIECE(%B3,U,2)
- IF %B["C"!%B
- KILL %A
- QUIT
- +3 if '$DATA(DIR("B"))
- if $DATA(DA)#2
- DO DA^DIRQ
- +4 if '$DATA(DIR("A"))
- SET %P=$$LABEL^DIALOGZ(%B1,%B2)_": "
- if $PIECE(%B3,U,2)'["R"
- SET %A=%A_"O"
- +5 ;IN DIR1, "1"=DATA DICTIONARY
- SET %T=1
- +6 ;if this a user-defined data type read
- NEW I
- SET I=+$PIECE(%B,"t",2)
- SET I=$PIECE($GET(^DI(.81,I,0)),U,2)
- IF I="S"
- SET I=$$GETPROP^DIETLIBF(%B1,%B2,"SET OF CODES")
- if I]""
- if %A'["A"
- DO S0(I)
- End DoDot:1
- if '$DATA(%A)
- GOTO EO
- GOTO NN
- +7 IF "FSYENDLP"'[%T
- GOTO EO
- +8 SET %B1=$PIECE(%B,":")
- SET %B2=$PIECE(%B,":",2)
- SET %B3=$PIECE(%B,":",3)
- +9 if '$LENGTH(%B2)
- SET %B2=$SELECT(%T="D":9991231,%T="F":245,1:999999999999)
- +10 IF %T="F"
- IF %B2>245
- SET %B2=245
- +11 IF %T="Y"
- SET %B=$$EZBLD^DIALOG(7003)
- +12 IF %T="D"
- SET %DT=$PIECE(%B3,"A")_$PIECE(%B3,"A",2)
- +13 IF %T="D"
- IF '$DATA(DIR("?"))
- SET %W0=%W0_$SELECT(%B3["R":$$EZBLD^DIALOG(8043),%B3["T":$$EZBLD^DIALOG(8044),1:"")
- +14 IF %T="D"
- SET %D1=%B1
- SET %D2=%B2
- IF %B["NOW"!(%B["DT")
- DO NOW^%DTC
- KILL %I,%H
- SET DT=X
- if %B1["NOW"
- SET %B1=%
- if %B1["DT"
- SET %B1=X
- if %B2["NOW"
- SET %B2=%
- if %B2["DT"
- SET %B2=X
- KILL %
- +15 IF %T="P"
- SET %B1=$SELECT('%B1:U_%B1,'$DATA(^DIC(+%B1,0,"GL")):U,1:^("GL"))
- if %B1=U
- GOTO EO
- if '$DATA(@(%B1_"0)"))
- GOTO EO
- IF '$DATA(DIR("A"))
- SET %P=$$EZBLD^DIALOG(8042,$ORDER(^DD(+$PIECE(^(0),U,2),0,"NM",0)))
- QUIT
- NN IF %T="S"
- if %A'["A"
- DO S0(%B)
- +1 if $DATA(%P)
- QUIT
- +2 SET %P=""
- IF %A["A"
- if $DATA(DIR("A"))
- SET %P=DIR("A")
- QUIT
- +3 IF '$DATA(DIR("A"))
- SET %P=$$EZBLD^DIALOG($PIECE($TEXT(@%T),";",4))
- IF %T="D"
- SET %P=%P_$SELECT(%B3["R":$$EZBLD^DIALOG(8043),%B3["T":$$EZBLD^DIALOG(8044),1:"")
- +4 if $DATA(DIR("A"))
- SET %P=$SELECT(%T="Y":DIR("A")_"? ",%T="S":$$EZBLD^DIALOG(8045,DIR("A")),1:DIR("A")_": ")
- +5 ;'LIST', 'NUMERIC', 'DATE' types
- IF "LND"'[%T
- QUIT
- +6 ;**
- IF $LENGTH(%B1)
- SET %P=%P_" ("_$SELECT(%T="D":$$DATE^DIUTL(%B1)_"-"_$$DATE^DIUTL(%B2),1:%B1_"-"_%B2)_")"
- +7 SET %P=%P_$SELECT("?: "[$EXTRACT(%P,$LENGTH(%P)):"",1:":")_" "
- +8 QUIT
- +9 ;
- +10 ;
- S0(%B) ;CREATE PROMPT FOR READING A 'SET' TYPE. %B is the SET OF CODES
- +1 IF '$DATA(%P)
- SET %P=$SELECT($DATA(DIR("A")):DIR("A")_": ",%A["B":$$EZBLD^DIALOG(8046),1:$$EZBLD^DIALOG($PIECE($TEXT(S),";",4)))
- +2 ;"B" PARAMETER SHOWS THE CHOICES SEPARATED BY "/"S
- if %A'["B"
- QUIT
- +3 SET %P=%P_" ("
- +4 IF %B'[":"
- IF $ORDER(DIR("C",""))]""
- SET %I=""
- FOR
- SET %I=$ORDER(DIR("C",%I))
- if %I=""
- QUIT
- Begin DoDot:1
- +5 NEW Y
- SET Y=$PIECE(DIR("C",%I),":")
- if Y=""
- QUIT
- +6 IF $DATA(DIR("S"))#2
- XECUTE DIR("S")
- IF '$TEST
- QUIT
- +7 SET %P=%P_Y_"/"
- End DoDot:1
- +8 IF '$TEST
- FOR %I=1:1
- if $PIECE(%B,";",%I,999)=""
- QUIT
- Begin DoDot:1
- +9 NEW Y
- SET Y=$PIECE($PIECE(%B,";",%I),":")
- if Y=""
- QUIT
- +10 IF $DATA(DIR("S"))#2
- XECUTE DIR("S")
- IF '$TEST
- QUIT
- +11 SET %P=%P_Y_"/"
- End DoDot:1
- +12 SET %P=$EXTRACT(%P,1,$LENGTH(%P)-(%P?.E1"/"))_"): "
- +13 QUIT
- +14 ;
- +15 ;
- EO ;ABORT
- SET %T=""
- SET Y=-1
- QUIT
- +1 ;
- DIR(DIALA) ;** INSERTS DIALOGS INTO DIR ARRAY
- +1 NEW DIALN,DIALP
- +2 SET DIALN=$GET(DIR("DIALOG",DIALA))
- +3 ;GIVES US A MAKED REFERENCE PRIOR TO CALLING $$EZBLD^DIALOG
- if '$DATA(^DI(.84,0))
- QUIT
- if +DIALN'=DIALN
- QUIT
- if '$DATA(^(DIALN,2))
- QUIT
- +4 IF $DATA(DIR("DIALOG",DIALA))>9
- MERGE DIALP=DIR("DIALOG",DIALA)
- +5 KILL DIR(DIALA)
- DO BLD^DIALOG(DIALN,.DIALP,,"DIR(DIALA)","F")
- +6 QUIT
- +7 ;
- +8 ;
- RW ; Replace...With... ENTER WITH 'Y', EXIT WITH 'Y' CHANGED. CALLED FROM MANY ROUTINES
- +1 NEW %,L,DINAKED
- SET DINAKED=$NAME(^(0))
- SET DG=Y
- if $DATA(DTIME)[0
- SET DTIME=999
- A if $X>50
- WRITE !
- KILL DTOUT
- WRITE $$EZBLD^DIALOG(8047)
- READ X:DTIME
- IF '$TEST
- SET DTOUT=1
- SET X=""
- +1 if X=""
- GOTO B
- if X?1."^"
- GOTO Q
- if $EXTRACT(X)=U&($DATA(DIRWP)[0)&(Y'[X)
- GOTO Q
- if X?."?"
- GOTO Q
- if X="@"
- GOTO Q
- +2 ;**CCO/NI 'END'
- IF X="END"!(X="end")!(X=$$UP^DILIBF($$EZBLD^DIALOG(7097)))
- SET L=0
- DO H
- if '%&'$DATA(DTOUT)
- SET Y=Y_X
- GOTO A
- +3 IF Y[X
- SET D=X
- SET L=$LENGTH(X)
- DO H
- if '%&'$DATA(DTOUT)
- SET Y=$PIECE(Y,D,1)_X_$PIECE(Y,D,2,999)
- GOTO A
- +4 SET D=$PIECE(X,"...",1)
- SET DH=$FIND(Y,D)
- IF DH
- SET X=$PIECE(X,"...",2,99)
- SET X=$SELECT(X="":$LENGTH(Y)+1,1:$FIND(Y,X,DH))
- IF X
- SET DH=DH-$LENGTH(D)-1
- SET D=X
- SET L=D-DH-1
- DO H
- if '%&'$DATA(DTOUT)
- SET Y=$EXTRACT(Y,1,DH)_X_$EXTRACT(Y,D,999)
- GOTO A
- +5 WRITE $CHAR(7)," ??"
- GOTO A
- +6 ;
- H NEW DIMAX
- WITH WRITE $$EZBLD^DIALOG(8048)
- READ X:DTIME
- IF '$TEST
- SET DTOUT=1
- SET X=""
- SET %=0
- WRITE $CHAR(7)," ??"
- QUIT
- +1 SET DIMAX=$GET(^DD("STRING_LIMIT"),255)-10
- SET %=$LENGTH(Y)-L+$LENGTH(X)>DIMAX
- +2 IF %
- WRITE $CHAR(7),$SELECT($LENGTH(Y)-L'>DIMAX:$$EZBLD^DIALOG(349,($LENGTH(Y)-L+$LENGTH(X)-DIMAX)),X'=U:$$EZBLD^DIALOG(350),1:" ??")
- if $LENGTH(Y)-L>DIMAX&(X=U)
- QUIT
- GOTO WITH
- +3 if X?.ANP
- QUIT
- WRITE $CHAR(7)," ??"
- GOTO WITH
- +4 ;
- B if $DATA(DTOUT)
- WRITE $CHAR(7)
- IF DG'=Y
- SET X=Y
- WRITE !?3
- WRITE X
- IF X=""
- SET X="@"
- +1 ;p8
- if DINAKED]""
- SET DINAKED=$SELECT(DINAKED["""""":$ORDER(@DINAKED),1:$DATA(@DINAKED))
- Q QUIT
- +1 ;
- F ;;Enter response: ;8051
- S ;;Enter response: ;8051
- Y ;;Enter Yes or No: ;8052
- E ;;Press RETURN to continue or '^' to exit: ;8053
- N ;;Enter a number;8054
- D ;;Enter a date;8055
- L ;;Enter a list or range of numbers;8056
- P ;;Select: ;8057
- F1 ;;;This response can be free text;9031
- S1 ;;;Enter a code from the list.;9032
- Y1 ;;;Enter either 'Y' or 'N'.;9040
- E1 ;;;Enter either RETURN or '^';9033
- N1 ;;;This response must be a number;9034
- D1 ;;;This response must be a date;9035
- L1 ;;;This response must be a list or range, e.g., 1,3,5 or 2-4,8;9036
- +1 ;
- +2 ;#349 String too long by |nuber| character(s)!
- +3 ;#350 String too long! '^' to quit.
- +4 ;#8041 This is a required response...
- +5 ;#8042 Select |1|
- +6 ;#8043 and time
- +7 ;#8044 and optional time
- +8 ;#8045 Enter |1|
- +9 ;#8046 Select one of the following
- +10 ;#8047 Replace
- +11 ;#8048 With
