DIOU ;SFISC/TKW - GENERIC FILEMAN CODE GENERATION UTILITIES ;18SEP2015
;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
;;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.
;
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) ;
;Called by ^DIP12
;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" Q:$P(%,U,2)["D"
;NOW IF IT HAS AN OUTPUT TRANSFORM, AND IS NOT A DATE, DO THE OUTPUT TRANSFORM. Compare with DT+2^DIO0
S E=",Y="_X_" "_$$OUTPUT^DIETLIBF(S,F)_" S "_X_"=Y"
I $P(%,U,2)["t"&($P(%,U,2)'["S")!($P(%,U,2)["O") S Y=Y_E
Q
;
CAL S Y=$P(%,U,5,99),E=$P($P(%,U,2),"p",2) ;IT'S A COMPUTED FIELD WE ARE AFTER
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) INTO 'Y' FOR A FIELD S,F CALLED FROM DIP,DIP1,DIEV, ETC
K Y S Y=""
I $G(F)=.001,$G(^DD(+$G(S),F,0))="" S Y=2 Q ;AN IEN IS NUMERIC
D2 Q:$G(^DD(+$G(S),+$G(F),0))=""
N %,%X,%Y,X,I,J,DITYP,DISETST,DIIT
S %=$P(^(0),U,2),DISETST=$P(^(0),U,3),DIIT=$P(^(0),U,5,99),DITYP=""
TYPE I %["t" S DITYP=+$P(%,"t",2) I $D(^DI(.81,DITYP,0)) S Y=DITYP,%=$P(^(0),U,2),DISETST=$$GETPROP^DIETLIBF(S,F,"SET OF CODES") ;EXTENSIBLE DATA TYPE
I '% S I="" F S I=$O(^DI(.81,"C",I)) Q:I="" I %[I S DITYP=$O(^(I,0)) Q ;LOOK THRU THE ABBREVIATIONS ("N", "S", etc)
I DITYP="",% D Q
. I $P($G(^DD(+%,.01,0)),U,2)["W" S Y=5 Q
. S Y=10,Y(+%)="" Q ;MULTIPLE
S:DITYP="" DITYP=4 ;'FREE-TEXT' IS THE DEFAULT
S:Y="" Y=DITYP
I DITYP=1 S Y("D")="",DIIT=$P($P(DIIT,"%DT=",2),"""",2) S:DIIT["T"!(DIIT["R")!(DIIT="") Y("D")=Y("D")_"T" S:DIIT["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(DISETST,";",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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIOU 4280 printed Oct 16, 2024@18:53:06 Page 2
DIOU ;SFISC/TKW - GENERIC FILEMAN CODE GENERATION UTILITIES ;18SEP2015
+1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
+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 ;
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) ;
+1 ;Called by ^DIP12
+2 ;BUILD CODE TO EXTRACT FIELD. S=FILE/SUBFILE#, F=FIELD#, X=LOCAL VARIABLE NAME WHERE FIELD WILL BE STORED. CODE RETURNED IN Y
+3 ; DIFLAG["I" if internal value of field (no output transform)
+4 NEW %
KILL Y
if '$DATA(^DD(+$GET(S),+$GET(F),0))
QUIT
SET %=^(0)
SET %(2)=$GET(^(2))
+5 NEW P,DN,I,J,E
+6 SET P=1
DO GLRF(S,F,.Y,.P)
+7 IF F=.001
IF P=""
SET Y="S "_X_"=D"_P(1)
QUIT
+8 IF P=" "
GOTO CAL
+9 SET (DN,E)=""
+10 IF P
SET DN="$P("
SET E="),U"_$SELECT(P=1:")",1:","_P_")")
+11 IF $EXTRACT(P)="E"
SET DN="$E("
SET E="),"_$EXTRACT(P,2,9)_")"
+12 IF P="W"
SET E=")"
+13 IF E=""
KILL Y
QUIT
+14 SET Y="S "_X_"="_DN_"$G("_Y_E
+15 if $GET(DIFLAG)["I"
QUIT
if $PIECE(%,U,2)["D"
QUIT
+16 ;NOW IF IT HAS AN OUTPUT TRANSFORM, AND IS NOT A DATE, DO THE OUTPUT TRANSFORM. Compare with DT+2^DIO0
+17 SET E=",Y="_X_" "_$$OUTPUT^DIETLIBF(S,F)_" S "_X_"=Y"
+18 IF $PIECE(%,U,2)["t"&($PIECE(%,U,2)'["S")!($PIECE(%,U,2)["O")
SET Y=Y_E
+19 QUIT
+20 ;
CAL ;IT'S A COMPUTED FIELD WE ARE AFTER
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) INTO 'Y' FOR A FIELD S,F CALLED FROM DIP,DIP1,DIEV, ETC
+1 KILL Y
SET Y=""
+2 ;AN IEN IS NUMERIC
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
+1 NEW %,%X,%Y,X,I,J,DITYP,DISETST,DIIT
+2 SET %=$PIECE(^(0),U,2)
SET DISETST=$PIECE(^(0),U,3)
SET DIIT=$PIECE(^(0),U,5,99)
SET DITYP=""
TYPE ;EXTENSIBLE DATA TYPE
IF %["t"
SET DITYP=+$PIECE(%,"t",2)
IF $DATA(^DI(.81,DITYP,0))
SET Y=DITYP
SET %=$PIECE(^(0),U,2)
SET DISETST=$$GETPROP^DIETLIBF(S,F,"SET OF CODES")
+1 ;LOOK THRU THE ABBREVIATIONS ("N", "S", etc)
IF '%
SET I=""
FOR
SET I=$ORDER(^DI(.81,"C",I))
if I=""
QUIT
IF %[I
SET DITYP=$ORDER(^(I,0))
QUIT
+2 IF DITYP=""
IF %
Begin DoDot:1
+3 IF $PIECE($GET(^DD(+%,.01,0)),U,2)["W"
SET Y=5
QUIT
+4 ;MULTIPLE
SET Y=10
SET Y(+%)=""
QUIT
End DoDot:1
QUIT
+5 ;'FREE-TEXT' IS THE DEFAULT
if DITYP=""
SET DITYP=4
+6 if Y=""
SET Y=DITYP
+7 IF DITYP=1
SET Y("D")=""
SET DIIT=$PIECE($PIECE(DIIT,"%DT=",2),"""",2)
if DIIT["T"!(DIIT["R")!(DIIT="")
SET Y("D")=Y("D")_"T"
if DIIT["S"
SET Y("D")=Y("D")_"S"
GOTO QD
+8 IF DITYP
IF "2,4,5,9"[DITYP
GOTO QD
+9 if Y=""
QUIT
+10 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(DISETST,";",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
+2 ;
+3 ;
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
