- DIOU ;SFISC/TKW-GENERIC FILEMAN CODE GENERATION UTILITIES ;03:57 PM 5 Dec 2001 [ 12/09/2003 4:33 PM ]
- ;;22.0;VA FileMan;**76,1002**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- BIJ(S,F,I,J) ;BUILD I & J ARRAY. S=(SUB)FILE#, F=FIELD#
- N X,Y,% S X=0,(Y,J(0))=S F Q:'$D(^DD(Y,0,"UP")) S X=X+1,Y=^("UP")
- I X=0 G X
- F %=X:-1:1 S Y=$G(^DD(S,0,"UP")) Q:'Y S I(S)=%,I(S,0)=Y,F=$O(^DD(Y,"SB",S,0)) Q:'F S I(S,1)=$P($P($G(^DD(Y,F,0)),U,4),";"),S=Y
- X S J=$G(^DIC(S,0,"GL")),I(S)=0
- I $G(DCC)?1"^"1.A1"(".E,((J="")!($P(DCC,J,2)]"")) S J=DCC
- Q
- ;
- GREF(I,J,F) ;BUILD GLOBAL REFERENCE (I & J ARRAY FROM BIJ, CODE RETURNED IN F)
- N %,Y S F="",%=J(0) F Y=I(%):-1 S F="D"_Y_F Q:'Y S F=","_$G(I(%,1))_","_F,%=$G(I(%,0)) Q:%=""!('$D(^DD(+%)))
- S F=$S($D(I(%,8)):I(%,8),1:J)_F Q
- ;
- GLRF(S,F,X,%) ;BUILD GLOBAL REFERENCE (S=(SUB)FILE#,F=FIELD NO.,%=CLOSE PARENTHESIS, RETURN PIECE IN %, X=OUTPUT VARIABLE.)
- Q:'$D(^DD($G(S),$G(F),0)) N I,J,K,L,Y D BIJ(S,F,.I,.J)
- S X="",K=J(0) F Y=I(K):-1 S X="D"_Y_X Q:'Y S L=$G(I(K,1)) S:L]""&(+$P(L,"E")'=L) L=$$QUOTE^DILIBF(L) S:L]"" X=","_L_","_X S K=+$G(I(K,0)) Q:'K
- S X=J_X_"," Q:$G(%)=""
- S %=$P($P(^DD(S,F,0),U,4),";") I %]"",+$P(%,"E")'=% S %=$$QUOTE^DILIBF(%)
- S X=X_%_")"
- S %=$P($P(^DD(S,F,0),U,4),";",2) S:$P(^(0),U,2)["W" %="W" S:F=.001 %(1)=I(J(0))
- Q
- ;
- GET(S,F,X,Y,DIFLAG) ;BUILD CODE TO EXTRACT FIELD. S=FILE/SUBFILE#, F=FIELD#, X=LOCAL VARIABLE NAME WHERE FIELD WILL BE STORED. CODE RETURNED IN Y
- ; DIFLAG["I" if internal value of field (no output transform)
- N % K Y Q:'$D(^DD(+$G(S),+$G(F),0)) S %=^(0),%(2)=$G(^(2))
- N P,DN,I,J,E
- S P=1 D GLRF(S,F,.Y,.P)
- I F=.001,P="" S Y="S "_X_"=D"_P(1) Q
- I P=" " G CAL
- S (DN,E)=""
- I P S DN="$P(",E="),U"_$S(P=1:")",1:","_P_")")
- I $E(P)="E" S DN="$E(",E="),"_$E(P,2,9)_")"
- I P="W" S E=")"
- I E="" K Y Q
- S Y="S "_X_"="_DN_"$G("_Y_E
- Q:$G(DIFLAG)["I"
- I %(2)]"",$P(%,U,2)["O",$P(%,U,2)'["D" S Y=Y_",Y="_X_" "_%(2)_" S "_X_"=Y"
- Q
- ;
- CAL S Y=$P(%,U,5,99),E=$P($P(%,U,2),"p",2)
- I E,$D(^DIC(+E,0,"GL")) S E=" S "_X_"=$S(X="""":X,$D("_^("GL")_"X,0))#2:$P(^(0),U),1:X)" S:$L(Y)+$L(E)>225 Y="X $P(^DD("_S_","_F_",0),U,5,99)" S Y=Y_E Q ;computed pointer
- S Y=Y_" S "_X_"=X" Q
- ;
- DTYP(S,F,Y) ;RETURN DATA TYPES(S) FOR A FIELD
- K Y S Y=""
- I $G(F)=.001,$G(^DD(+$G(S),F,0))="" S Y=2 Q
- D2 Q:$G(^DD(+$G(S),+$G(F),0))="" N %,%X,%Y,X,I,J,DITYP
- S %=$P(^(0),U,2),%(1)=$P(^(0),U,3),%(4)=$P(^(0),U,5,99),DITYP=""
- I '% S I="" F S I=$O(^DI(.81,"C",I)) Q:I="" I %[I S DITYP=$O(^(I,0)) Q
- I DITYP="",% D Q
- . I $P($G(^DD(+%,.01,0)),U,2)["W" S Y=5 Q
- . S Y=10,Y(+%)="" Q
- S:DITYP="" DITYP=4
- S:Y="" Y=DITYP
- I DITYP=1 S Y("D")="",%(4)=$P($P(%(4),"%DT=",2),"""",2) S:%(4)["T"!(%(4)["R")!(%(4)="") Y("D")=Y("D")_"T" S:%(4)["S" Y("D")=Y("D")_"S" G QD
- I DITYP,"2,4,5,9"[DITYP G QD
- Q:Y=""
- I DITYP=6 S Y("T")=$S(%["D":1,%["B":2,%?.E1"J".N1","1N.E:2,%["p":7,1:4) Q
- P I DITYP=7 S I=+$P(%,"P",2),%(2)="Y(" D Y S S=I,F=.01 K % G D2
- V I DITYP=8 S X=0 D V2 Q
- S I DITYP=3 F I=1:1 S X=$P(%(1),";",I),X(1)=$P(X,":"),X=$P(X,":",2) Q:X=""!(X(1)="") S Y("S","I",X(1))=X,Y("S","E",X)=X(1)
- QD I $O(Y(-1)) S Y("T")=DITYP
- Q
- Y S %(3)=$O(@(%(2)_"0)")) I %(3)]"",%(3)'="T" S %(2)=%(2)_%(3)_"," G Y
- S %(2)=%(2)_I,@(%(2)_")")="" Q
- V2 S X=$O(^DD(S,F,"V",X)) Q:'X S I=$P($G(^DD(S,F,"V",X,0)),U) G:'I V2
- S:'$D(Y("V"_X)) Y("V"_X)="" S %(2)="Y("_"""V"_X_"""," D Y
- D DTYP(.I,.01,.J)
- I J>0 S (Y("T"),Y("V"_X,"T"))=$S($G(J("T"))]"":J("T"),1:J) K J("T") S %X="J(",%Y=%(2)_"," D %XY^%RCR
- K %,J G V2
- DIOU ;SFISC/TKW-GENERIC FILEMAN CODE GENERATION UTILITIES ;03:57 PM 5 Dec 2001 [ 12/09/2003 4:33 PM ]
- +1 ;;22.0;VA FileMan;**76,1002**;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- BIJ(S,F,I,J) ;BUILD I & J ARRAY. S=(SUB)FILE#, F=FIELD#
- +1 NEW X,Y,%
- SET X=0
- SET (Y,J(0))=S
- FOR
- IF '$DATA(^DD(Y,0,"UP"))
- QUIT
- SET X=X+1
- SET Y=^("UP")
- +2 IF X=0
- GOTO X
- +3 FOR %=X:-1:1
- SET Y=$GET(^DD(S,0,"UP"))
- IF 'Y
- QUIT
- SET I(S)=%
- SET I(S,0)=Y
- SET F=$ORDER(^DD(Y,"SB",S,0))
- IF 'F
- QUIT
- SET I(S,1)=$PIECE($PIECE($GET(^DD(Y,F,0)),U,4),";")
- SET S=Y
- X SET J=$GET(^DIC(S,0,"GL"))
- SET I(S)=0
- +1 IF $GET(DCC)?1"^"1.A1"(".E
- IF ((J="")!($PIECE(DCC,J,2)]""))
- SET J=DCC
- +2 QUIT
- +3 ;
- GREF(I,J,F) ;BUILD GLOBAL REFERENCE (I & J ARRAY FROM BIJ, CODE RETURNED IN F)
- +1 NEW %,Y
- SET F=""
- SET %=J(0)
- FOR Y=I(%):-1
- SET F="D"_Y_F
- IF 'Y
- QUIT
- SET F=","_$GET(I(%,1))_","_F
- SET %=$GET(I(%,0))
- IF %=""!('$DATA(^DD(+%)))
- QUIT
- +2 SET F=$SELECT($DATA(I(%,8)):I(%,8),1:J)_F
- QUIT
- +3 ;
- GLRF(S,F,X,%) ;BUILD GLOBAL REFERENCE (S=(SUB)FILE#,F=FIELD NO.,%=CLOSE PARENTHESIS, RETURN PIECE IN %, X=OUTPUT VARIABLE.)
- +1 IF '$DATA(^DD($GET(S),$GET(F),0))
- QUIT
- NEW I,J,K,L,Y
- DO BIJ(S,F,.I,.J)
- +2 SET X=""
- SET K=J(0)
- FOR Y=I(K):-1
- SET X="D"_Y_X
- IF 'Y
- QUIT
- SET L=$GET(I(K,1))
- IF L]""&(+$PIECE(L,"E")'=L)
- SET L=$$QUOTE^DILIBF(L)
- IF L]""
- SET X=","_L_","_X
- SET K=+$GET(I(K,0))
- IF 'K
- QUIT
- +3 SET X=J_X_","
- IF $GET(%)=""
- QUIT
- +4 SET %=$PIECE($PIECE(^DD(S,F,0),U,4),";")
- IF %]""
- IF +$PIECE(%,"E")'=%
- SET %=$$QUOTE^DILIBF(%)
- +5 SET X=X_%_")"
- +6 SET %=$PIECE($PIECE(^DD(S,F,0),U,4),";",2)
- IF $PIECE(^(0),U,2)["W"
- SET %="W"
- IF F=.001
- SET %(1)=I(J(0))
- +7 QUIT
- +8 ;
- GET(S,F,X,Y,DIFLAG) ;BUILD CODE TO EXTRACT FIELD. S=FILE/SUBFILE#, F=FIELD#, X=LOCAL VARIABLE NAME WHERE FIELD WILL BE STORED. CODE RETURNED IN Y
- +1 ; DIFLAG["I" if internal value of field (no output transform)
- +2 NEW %
- KILL Y
- IF '$DATA(^DD(+$GET(S),+$GET(F),0))
- QUIT
- SET %=^(0)
- SET %(2)=$GET(^(2))
- +3 NEW P,DN,I,J,E
- +4 SET P=1
- DO GLRF(S,F,.Y,.P)
- +5 IF F=.001
- IF P=""
- SET Y="S "_X_"=D"_P(1)
- QUIT
- +6 IF P=" "
- GOTO CAL
- +7 SET (DN,E)=""
- +8 IF P
- SET DN="$P("
- SET E="),U"_$SELECT(P=1:")",1:","_P_")")
- +9 IF $EXTRACT(P)="E"
- SET DN="$E("
- SET E="),"_$EXTRACT(P,2,9)_")"
- +10 IF P="W"
- SET E=")"
- +11 IF E=""
- KILL Y
- QUIT
- +12 SET Y="S "_X_"="_DN_"$G("_Y_E
- +13 IF $GET(DIFLAG)["I"
- QUIT
- +14 IF %(2)]""
- IF $PIECE(%,U,2)["O"
- IF $PIECE(%,U,2)'["D"
- SET Y=Y_",Y="_X_" "_%(2)_" S "_X_"=Y"
- +15 QUIT
- +16 ;
- CAL SET Y=$PIECE(%,U,5,99)
- SET E=$PIECE($PIECE(%,U,2),"p",2)
- +1 ;computed pointer
- IF E
- IF $DATA(^DIC(+E,0,"GL"))
- SET E=" S "_X_"=$S(X="""":X,$D("_^("GL")_"X,0))#2:$P(^(0),U),1:X)"
- IF $LENGTH(Y)+$LENGTH(E)>225
- SET Y="X $P(^DD("_S_","_F_",0),U,5,99)"
- SET Y=Y_E
- QUIT
- +2 SET Y=Y_" S "_X_"=X"
- QUIT
- +3 ;
- DTYP(S,F,Y) ;RETURN DATA TYPES(S) FOR A FIELD
- +1 KILL Y
- SET Y=""
- +2 IF $GET(F)=.001
- IF $GET(^DD(+$GET(S),F,0))=""
- SET Y=2
- QUIT
- D2 IF $GET(^DD(+$GET(S),+$GET(F),0))=""
- QUIT
- NEW %,%X,%Y,X,I,J,DITYP
- +1 SET %=$PIECE(^(0),U,2)
- SET %(1)=$PIECE(^(0),U,3)
- SET %(4)=$PIECE(^(0),U,5,99)
- SET DITYP=""
- +2 IF '%
- SET I=""
- FOR
- SET I=$ORDER(^DI(.81,"C",I))
- IF I=""
- QUIT
- IF %[I
- SET DITYP=$ORDER(^(I,0))
- QUIT
- +3 IF DITYP=""
- IF %
- Begin DoDot:1
- +4 IF $PIECE($GET(^DD(+%,.01,0)),U,2)["W"
- SET Y=5
- QUIT
- +5 SET Y=10
- SET Y(+%)=""
- QUIT
- End DoDot:1
- QUIT
- +6 IF DITYP=""
- SET DITYP=4
- +7 IF Y=""
- SET Y=DITYP
- +8 IF DITYP=1
- SET Y("D")=""
- SET %(4)=$PIECE($PIECE(%(4),"%DT=",2),"""",2)
- IF %(4)["T"!(%(4)["R")!(%(4)="")
- SET Y("D")=Y("D")_"T"
- IF %(4)["S"
- SET Y("D")=Y("D")_"S"
- GOTO QD
- +9 IF DITYP
- IF "2,4,5,9"[DITYP
- GOTO QD
- +10 IF Y=""
- QUIT
- +11 IF DITYP=6
- SET Y("T")=$SELECT(%["D":1,%["B":2,%?.E1"J".N1","1N.E:2,%["p":7,1:4)
- QUIT
- P IF DITYP=7
- SET I=+$PIECE(%,"P",2)
- SET %(2)="Y("
- DO Y
- SET S=I
- SET F=.01
- KILL %
- GOTO D2
- V IF DITYP=8
- SET X=0
- DO V2
- QUIT
- S IF DITYP=3
- FOR I=1:1
- SET X=$PIECE(%(1),";",I)
- SET X(1)=$PIECE(X,":")
- SET X=$PIECE(X,":",2)
- IF X=""!(X(1)="")
- QUIT
- SET Y("S","I",X(1))=X
- SET Y("S","E",X)=X(1)
- QD IF $ORDER(Y(-1))
- SET Y("T")=DITYP
- +1 QUIT
- Y SET %(3)=$ORDER(@(%(2)_"0)"))
- IF %(3)]""
- IF %(3)'="T"
- SET %(2)=%(2)_%(3)_","
- GOTO Y
- +1 SET %(2)=%(2)_I
- SET @(%(2)_")")=""
- QUIT
- V2 SET X=$ORDER(^DD(S,F,"V",X))
- IF 'X
- QUIT
- SET I=$PIECE($GET(^DD(S,F,"V",X,0)),U)
- IF 'I
- GOTO V2
- +1 IF '$DATA(Y("V"_X))
- SET Y("V"_X)=""
- SET %(2)="Y("_"""V"_X_""","
- DO Y
- +2 DO DTYP(.I,.01,.J)
- +3 IF J>0
- SET (Y("T"),Y("V"_X,"T"))=$SELECT($GET(J("T"))]"":J("T"),1:J)
- KILL J("T")
- SET %X="J("
- SET %Y=%(2)_","
- DO %XY^%RCR
- +4 KILL %,J
- GOTO V2
