- %ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88 2:02 PM ;1/24/08 16:10
- ;;8.0;KERNEL;**69,440,584**;JUL 10, 1995;Build 7
- ;Per VHA Directive 2004-038, this routine should not be modified
- VALID ;
- N %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440
- D L
- Q
- ;
- SET2 ;
- S %ZISFN="" F %ZISZ=0:0 S %ZISFN=$O(%ZISZ(%ZISFN)) Q:%ZISFN="" I $D(%ZISZ(%ZISFN))#2 S %ZISXX=%ZISZ(%ZISFN) D INDCK
- Q
- INDCK ;
- S %ZISY=""
- I "IOEFLD^IOSTBM"[%ZISFN S @%ZISFN=%ZISXX Q
- I %ZISXX]"" S @("%ZISY="_%ZISXX)
- ;E S @("%ZISY="_"""""")
- I $E(%ZISFN,1,2)="IO" S @%ZISFN=%ZISY
- E S @("IO"_$E(%ZISFN,1,6))=%ZISY
- Q:'($D(%ZIS)#2) Q:%ZIS'["I" Q:'$D(%ZISZ(%ZISFN,1))
- ;
- SRAY ;
- S %=%ZISY,%ZISY=$A($E(%ZISY,1))
- F %1=2:1:$L(%) S %ZISY=%ZISY_$S($A(%,%1)<32:$A(%,%1),$A(%,%1)=127:127,1:$E(%,%1))
- S IOIS(%ZISY)=%ZISFN
- Q
- CHECK ;Entry point called from input transforms of fields in DEV/TT files.
- N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440
- S %ZISXX=X D L S X=%ZISYY
- Q
- CHECK1 ;Entry point called from input transforms of fields in DEV/TT files.
- N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440
- S %ZISXX=$S(X?1"W ".E:$E(X,3,$L(X)),1:X)
- D L S X=$S(X?1"W ".E:"W "_%ZISYY,1:%ZISYY)
- Q
- FORM ;Entry point called from input transforms of fields in DEV/TT files.
- Q:$L(X,"_")'>1
- N %ZISSI,%ZISSY ;p440
- ;F %ZISSI=1:1:$L(X,"_") S %ZISX1=$P(X,"_",%ZISSI) I %ZISX1]"","#?!"[$E(%ZISX1) S X=$S(%ZISSI=1:"",1:$P(X,"_",1,%ZISSI-1)_",")_%ZISX1_$S(%ZISSI<$L(X,"_"):","_$P(X,"_",%ZISSI+1,255),1:"") W !,%ZISSI_"==>"_X
- S %ZISSY=""
- F %ZISSI=1:1:$L(X,"_") S %ZISSY=%ZISSY_$P(X,"_",%ZISSI)_$S($P(X,"_",%ZISSI+1)="":"","#?!"[$E($P(X,"_",%ZISSI+1)):",","#?!"[$E($P(X,"_",%ZISSI)):",",1:"_")
- S X=%ZISSY
- Q
- ;
- L S ZISQ="""",%ZISNP=0,ZISXLN=$L(%ZISXX) I 'ZISXLN S %ZISYY="" Q
- S ZISXL=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'<ZISXLN
- ;I $L(%ZISYY,"$C(")>2,%ZISYY[")_$C(" S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX Q
- S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX
- Q
- L1 I ZISCH="_"!(ZISCH=",") S %ZISYY=%ZISYY_"_" Q
- I ZISCH=ZISQ D QUOTE Q
- I ZISCH="$" D DOLR Q
- I ZISCH="*" D STAR Q
- I ZISCH="(" D PAREN Q
- S %ZISYY=%ZISYY_ZISCH
- Q
- L2 ;Find $C(x)_$C(y) and merge
- N I ;p440
- F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2
- Q
- L3 ;
- N I
- F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")"
- Q
- STAR ;S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH?1N ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_+ZISNUM_")",ZISXL=ZISXL-1 Q
- S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH'=""&(ZISCH'=",") ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_ZISNUM_")",ZISXL=ZISXL-1 Q
- Q
- QUOTE S %ZISYY=%ZISYY_ZISCH F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL),%ZISYY=%ZISYY_ZISCH I ZISCH=ZISQ!(ZISXL'<ZISXLN) Q
- Q
- DOLR ;Looking for $C.
- I "IXY"[$E(%ZISXX,ZISXL+1) S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1) S ZISXL=ZISXL+1 Q
- I "ACDEFJLNOPRSTV"[$E(%ZISXX,ZISXL+1)&($E(%ZISXX,ZISXL+2)="(") S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1),ZISXL=ZISXL+2 D PAREN Q
- S %ZISYY=%ZISYY_"$" ;p440
- Q
- PAREN S %ZISYY=%ZISYY_"(",ZISEND=")",%ZISNP=%ZISNP+1 D SCAN S %ZISNP=%ZISNP-1
- Q
- SCAN F %ZISI=0:0 S ZISXL=ZISXL+1,ZISCH=$E(%ZISXX,ZISXL) D S1 Q:ZISXL'<ZISXLN!(ZISEND=ZISCH&(%ZISNP))
- Q
- S1 I ZISCH=ZISQ D QUOTE Q
- I ZISCH="$" D DOLR Q
- I ZISCH="(" D PAREN Q
- S %ZISYY=%ZISYY_ZISCH
- Q
- ;
- S2 ;MERGE $C
- S %ZISX1=$E(%ZISX1,1,$L(%ZISX1)-1),%ZISX2=","_$E(%ZISX2,4,$L(%ZISX2))
- S $P(%ZISXX,"_",I,I+1)=%ZISX1_%ZISX2
- N I D L2
- Q
- %ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88 2:02 PM ;1/24/08 16:10
- +1 ;;8.0;KERNEL;**69,440,584**;JUL 10, 1995;Build 7
- +2 ;Per VHA Directive 2004-038, this routine should not be modified
- VALID ;
- +1 ;p440
- NEW %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN
- +2 DO L
- +3 QUIT
- +4 ;
- SET2 ;
- +1 SET %ZISFN=""
- FOR %ZISZ=0:0
- SET %ZISFN=$ORDER(%ZISZ(%ZISFN))
- IF %ZISFN=""
- QUIT
- IF $DATA(%ZISZ(%ZISFN))#2
- SET %ZISXX=%ZISZ(%ZISFN)
- DO INDCK
- +2 QUIT
- INDCK ;
- +1 SET %ZISY=""
- +2 IF "IOEFLD^IOSTBM"[%ZISFN
- SET @%ZISFN=%ZISXX
- QUIT
- +3 IF %ZISXX]""
- SET @("%ZISY="_%ZISXX)
- +4 ;E S @("%ZISY="_"""""")
- +5 IF $EXTRACT(%ZISFN,1,2)="IO"
- SET @%ZISFN=%ZISY
- +6 IF '$TEST
- SET @("IO"_$EXTRACT(%ZISFN,1,6))=%ZISY
- +7 IF '($DATA(%ZIS)#2)
- QUIT
- IF %ZIS'["I"
- QUIT
- IF '$DATA(%ZISZ(%ZISFN,1))
- QUIT
- +8 ;
- SRAY ;
- +1 SET %=%ZISY
- SET %ZISY=$ASCII($EXTRACT(%ZISY,1))
- +2 FOR %1=2:1:$LENGTH(%)
- SET %ZISY=%ZISY_$SELECT($ASCII(%,%1)<32:$ASCII(%,%1),$ASCII(%,%1)=127:127,1:$EXTRACT(%,%1))
- +3 SET IOIS(%ZISY)=%ZISFN
- +4 QUIT
- CHECK ;Entry point called from input transforms of fields in DEV/TT files.
- +1 ;p440
- NEW %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN
- +2 SET %ZISXX=X
- DO L
- SET X=%ZISYY
- +3 QUIT
- CHECK1 ;Entry point called from input transforms of fields in DEV/TT files.
- +1 ;p440
- NEW %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN
- +2 SET %ZISXX=$SELECT(X?1"W ".E:$EXTRACT(X,3,$LENGTH(X)),1:X)
- +3 DO L
- SET X=$SELECT(X?1"W ".E:"W "_%ZISYY,1:%ZISYY)
- +4 QUIT
- FORM ;Entry point called from input transforms of fields in DEV/TT files.
- +1 IF $LENGTH(X,"_")'>1
- QUIT
- +2 ;p440
- NEW %ZISSI,%ZISSY
- +3 ;F %ZISSI=1:1:$L">L(X,"_") S %ZISX1=$P(X,"_",%ZISSI) I %ZISX1]"","#?!"[$E(%ZISX1) S X=$S(%ZISSI=1:"",1:$P(X,"_",1,%ZISSI-1)_",")_%ZISX1_$S(%ZISSI<$L">L(X,"_"):","_$P(X,"_",%ZISSI+1,255),1:"") W !,%ZISSI_"==>"_X
- +4 SET %ZISSY=""
- +5 FOR %ZISSI=1:1:$LENGTH(X,"_")
- SET %ZISSY=%ZISSY_$PIECE(X,"_",%ZISSI)_$SELECT($PIECE(X,"_",%ZISSI+1)="":"","#?!"[$EXTRACT($PIECE(X,"_",%ZISSI+1)):",","#?!"[$EXTRACT($PIECE(X,"_",%ZISSI)):",",1:"_")
- +6 SET X=%ZISSY
- +7 QUIT
- +8 ;
- L SET ZISQ=""""
- SET %ZISNP=0
- SET ZISXLN=$LENGTH(%ZISXX)
- IF 'ZISXLN
- SET %ZISYY=""
- QUIT
- +1 SET ZISXL=0
- SET %ZISYY=""
- FOR %ZISI=0:0
- SET ZISXL=ZISXL+1
- SET ZISCH=$EXTRACT(%ZISXX,ZISXL)
- DO L1
- IF ZISXL'<ZISXLN
- QUIT
- +2 ;I $L(%ZISYY,"$C(")>2,%ZISYY[")_$C(" S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX Q
- +3 SET %ZISXX=%ZISYY
- DO L2
- DO L3
- SET %ZISYY=%ZISXX
- +4 QUIT
- L1 IF ZISCH="_"!(ZISCH=",")
- SET %ZISYY=%ZISYY_"_"
- QUIT
- +1 IF ZISCH=ZISQ
- DO QUOTE
- QUIT
- +2 IF ZISCH="$"
- DO DOLR
- QUIT
- +3 IF ZISCH="*"
- DO STAR
- QUIT
- +4 IF ZISCH="("
- DO PAREN
- QUIT
- +5 SET %ZISYY=%ZISYY_ZISCH
- +6 QUIT
- L2 ;Find $C(x)_$C(y) and merge
- +1 ;p440
- NEW I
- +2 FOR I=1:1:$LENGTH(%ZISXX,"_")
- SET %ZISX1=$PIECE(%ZISXX,"_",I)
- SET %ZISX2=$PIECE(%ZISXX,"_",I+1)
- IF $EXTRACT(%ZISX1,1,3)="$C("
- IF $EXTRACT(%ZISX2,1,3)="$C("
- DO S2
- +3 QUIT
- L3 ;
- +1 NEW I
- +2 FOR I=1:1:$LENGTH(%ZISXX,"_")
- IF $PIECE(%ZISXX,"_",I)["+"
- IF "$("'[$EXTRACT($PIECE(%ZISXX,"_",I))
- IF ")"'[$EXTRACT($PIECE(%ZISXX,"_",I),$LENGTH($PIECE(%ZISXX,"_",I)))
- SET $PIECE(%ZISXX,"_",I)="("_$PIECE(%ZISXX,"_",I)_")"
- +3 QUIT
- STAR ;S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH?1N ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_+ZISNUM_")",ZISXL=ZISXL-1 Q
- +1 SET ZISNUM=""
- FOR %ZISI=0:0
- SET ZISXL=ZISXL+1
- SET ZISCH=$EXTRACT(%ZISXX,ZISXL)
- IF ZISCH'=""&(ZISCH'=",")
- SET ZISNUM=ZISNUM_ZISCH
- IF ZISCH=""!(ZISCH=",")
- SET %ZISYY=%ZISYY_"$C("_ZISNUM_")"
- SET ZISXL=ZISXL-1
- QUIT
- +2 QUIT
- QUOTE SET %ZISYY=%ZISYY_ZISCH
- FOR %ZISI=0:0
- SET ZISXL=ZISXL+1
- SET ZISCH=$EXTRACT(%ZISXX,ZISXL)
- SET %ZISYY=%ZISYY_ZISCH
- IF ZISCH=ZISQ!(ZISXL'<ZISXLN)
- QUIT
- +1 QUIT
- DOLR ;Looking for $C.
- +1 IF "IXY"[$EXTRACT(%ZISXX,ZISXL+1)
- SET %ZISYY=%ZISYY_"$"_$EXTRACT(%ZISXX,ZISXL+1)
- SET ZISXL=ZISXL+1
- QUIT
- +2 IF "ACDEFJLNOPRSTV"[$EXTRACT(%ZISXX,ZISXL+1)&($EXTRACT(%ZISXX,ZISXL+2)="(")
- SET %ZISYY=%ZISYY_"$"_$EXTRACT(%ZISXX,ZISXL+1)
- SET ZISXL=ZISXL+2
- DO PAREN
- QUIT
- +3 ;p440
- SET %ZISYY=%ZISYY_"$"
- +4 QUIT
- PAREN SET %ZISYY=%ZISYY_"("
- SET ZISEND=")"
- SET %ZISNP=%ZISNP+1
- DO SCAN
- SET %ZISNP=%ZISNP-1
- +1 QUIT
- SCAN FOR %ZISI=0:0
- SET ZISXL=ZISXL+1
- SET ZISCH=$EXTRACT(%ZISXX,ZISXL)
- DO S1
- IF ZISXL'<ZISXLN!(ZISEND=ZISCH&(%ZISNP))
- QUIT
- +1 QUIT
- S1 IF ZISCH=ZISQ
- DO QUOTE
- QUIT
- +1 IF ZISCH="$"
- DO DOLR
- QUIT
- +2 IF ZISCH="("
- DO PAREN
- QUIT
- +3 SET %ZISYY=%ZISYY_ZISCH
- +4 QUIT
- +5 ;
- S2 ;MERGE $C
- +1 SET %ZISX1=$EXTRACT(%ZISX1,1,$LENGTH(%ZISX1)-1)
- SET %ZISX2=","_$EXTRACT(%ZISX2,4,$LENGTH(%ZISX2))
- +2 SET $PIECE(%ZISXX,"_",I,I+1)=%ZISX1_%ZISX2
- +3 NEW I
- DO L2
- +4 QUIT
