DITR ;SFISC/GFT-FIND FLDS TO XRF ;8SEP2011
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;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.
;
N DITRCNT
LOOP S (DFL,DTL)=DFL-1 Q:'$D(DFN(DFL))
N S @("DFN(DFL)=$O("_DFR(DFL)_"DFN(DFL)))")
I DFN(DFL)]"",$D(^(DFN(DFL)))#2 S Z=^(DFN(DFL)),A="" D:$G(DIFRFRV) SFRV1 G NS
G LOOP:DFN(DFL)="",1:DFL#2,LOOP:$D(^(DFN(DFL),0))-1 S Z=^(0),X="D"_(DFL\2),@X=DFN(DFL) I DTO,$D(DSC(DDF(DFL+1))) X DSC(DDF(DFL+1)) E G N
I $P(^DD(DDT(DTL),.01,0),U,2)["W" D ^DITR1 G N
D ^DITR1 I A D:$G(DIFRSA)]"" ERR G N
I $G(DIFRSA)]"",'DKP,@("$D("_DTO(DTL)_"Y))") D KILLIDX
D D,SFRV1:$G(DIFRFRV)
NS S A=$O(^DD(DDF(DFL),"GL",DFN(DFL),A)) G N:A=""
S W=$O(^(A,0)) S:W="" W=-1 G:$G(DIFRDKP) NS:$D(@DIFRSA@("^DD",DIFRFILE,DDF(DFL),W)) I A S Y=$P(Z,U,A) G NS:Y=""
E S Y=$E(Z,+$E(A,2,9),$P(A,",",2)) F %=$L(Y):-1 Q:" "'[$E(Y,%) G NS:'% S Y=$E(Y,1,%-1)
I DTO G NS:'$D(^UTILITY("DITR",$J,DDF(DFL),W)) S B=^(W),DTN(DTL)=$P(B,U,2)
E S B=A,DTN(DTL)=DFN(DFL)
S X="" I @("$D("_DTO(DTL)_"DTN(DTL)))#2") S X=^(DTN(DTL))
I 'B D G NS
.S W=$E(B,2,9),B=$P(B,",",2)
.I $E(X,+W,B)'?." "&DKP D:$G(DIFRFRV) KFRV1 Q
.S %=$E(X,B+1,999),V=W-$L(X)-1,^(DTN(DTL))=$E(X,0,W-1)_$J("",$S(V>0:V,1:0))_Y S:%'?." " ^(DTN(DTL))=^(DTN(DTL))_$J("",B+1-W-$L(Y))_%
.I $G(DIFRFRV) D SFRVL
.Q
I DKP,$P(X,U,B)]"" D:$G(DIFRFRV) KFRV1 G NS
P S $P(^(DTN(DTL)),U,B)=Y D:$G(DIFRFRV) SFRVL G NS
;
1 G N:$O(^(DFN(DFL),0))'>0 S Z=$O(^DD(DDF(DFL),"GL",DFN(DFL),0,0)) G N:Z'>0 I DTO G N:'$D(^UTILITY("DITR",$J,DDF(DFL),Z)) S B=^(Z)
D D S Y=$P(^DD(DDF(DFL-1),Z,0),U,2),DDF(DFL+1)=+Y I DTO S Y=$P(B,U,3),X=""""_$P(B,U,2)_""","
S DDT(DTL)=+Y,DTO(DTL)=DTO(DTL-1)_X S:$G(DIFRDKP) DIFRX=$D(@DIFRSA@("^DD",DIFRFILE,+Y)) I @("'$D("_DTO(DTL)_"0))") G:$G(DIFRDKP) LOOP:DIFRX S ^(0)=U_Y
G N
;
SFRV1 S DIFRFRV1=$P($NA(@("DIFRFRV(D0,"_$P(DFR(DFL),DFR(1),2,255)_""""_DFN(DFL)_""")")),"DIFRFRV(",2,255),$E(DIFRFRV1,$L(DIFRFRV1))=""
Q
SFRVL Q:'$D(@DIFRSA@("FRV1",DIFRFILE,DIFRFRV1))
S @DIFRSA@("FRVL",DIFRFILE,DIFRFRV1)=$NA(@(DTO(DTL)_""""_DFN(DFL)_""")"))
Q
KFRV1 K @DIFRSA@("FRV1",DIFRFILE,DIFRFRV1,B)
Q
;
D S DTL=DFL+1
S X=""""_DFN(DFL)_""",",DFR(DFL+1)=DFR(DFL)_X,DFL=DFL+1,DFN(DFL)=0 Q
;
F ;
S A=1,@("Z="_DIK_"D0,0)") W !,$P(^(0),U,1) G I:'DTO!'$D(DITF)
S Z=$P(DITF,";",1) I Z=" " S Z=D0 G I
Q:'$D(^(Z)) S X=$P(DITF,";",2) I X S Z=$P(^(Z),U,X) G I
S Z=$E(^(Z),+$E(X,2,9),+$P(X,",",2))
I ;
S DFL=0,DTL=0,DA=D0 D ^DITR1
I A D:$G(DIFRSA)]"" ERR Q
I $G(DIFRSA)]"" S DIFRND0=Y I 'DKP,@("$D("_DTO(DTL)_"Y))") D KILLIDX
GO ;
S DFL=1,DTL=1,DFN(1)=-1 D N
Q
;
KILLIDX ; Kill the old index for single entry (overwrite mode only).
N DIK,DA,%,A,B S DA=Y,DIK=DTO(DTL),DIK(0)="ABs"
S A=$$CREF^DILF(DIK),A=$NA(@A),B=$QL(A)-1 F %=1:1:DFL\2 S DA(%)=$QS(A,B),B=B-2 ;GET SUBSCRIPTED VALUES OF DA --GFT
N D0,DDF,DDT,DFL,DFR,DINUM,DTL,DTN,DTO,I,W,X,Y,Z
D IX2^DIK Q
;
ERR N DIPAR S DIPAR(.01)=X,DIPAR("IEN")=Y,DIPAR("FILE")=DDT(DFL)
D BLD^DIALOG(9513.1,.DIPAR) Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDITR 3221 printed Dec 13, 2024@02:54:30 Page 2
DITR ;SFISC/GFT-FIND FLDS TO XRF ;8SEP2011
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+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 ;
+7 NEW DITRCNT
LOOP SET (DFL,DTL)=DFL-1
if '$DATA(DFN(DFL))
QUIT
N SET @("DFN(DFL)=$O("_DFR(DFL)_"DFN(DFL)))")
+1 IF DFN(DFL)]""
IF $DATA(^(DFN(DFL)))#2
SET Z=^(DFN(DFL))
SET A=""
if $GET(DIFRFRV)
DO SFRV1
GOTO NS
+2 if DFN(DFL)=""
GOTO LOOP
if DFL#2
GOTO 1
if $DATA(^(DFN(DFL),0))-1
GOTO LOOP
SET Z=^(0)
SET X="D"_(DFL\2)
SET @X=DFN(DFL)
IF DTO
IF $DATA(DSC(DDF(DFL+1)))
XECUTE DSC(DDF(DFL+1))
IF '$TEST
GOTO N
+3 IF $PIECE(^DD(DDT(DTL),.01,0),U,2)["W"
DO ^DITR1
GOTO N
+4 DO ^DITR1
IF A
if $GET(DIFRSA)]""
DO ERR
GOTO N
+5 IF $GET(DIFRSA)]""
IF 'DKP
IF @("$D("_DTO(DTL)_"Y))")
DO KILLIDX
+6 DO D
if $GET(DIFRFRV)
DO SFRV1
NS SET A=$ORDER(^DD(DDF(DFL),"GL",DFN(DFL),A))
if A=""
GOTO N
+1 SET W=$ORDER(^(A,0))
if W=""
SET W=-1
if $GET(DIFRDKP)
if $DATA(@DIFRSA@("^DD",DIFRFILE,DDF(DFL),W))
GOTO NS
IF A
SET Y=$PIECE(Z,U,A)
if Y=""
GOTO NS
+2 IF '$TEST
SET Y=$EXTRACT(Z,+$EXTRACT(A,2,9),$PIECE(A,",",2))
FOR %=$LENGTH(Y):-1
if " "'[$EXTRACT(Y,%)
QUIT
if '%
GOTO NS
SET Y=$EXTRACT(Y,1,%-1)
+3 IF DTO
if '$DATA(^UTILITY("DITR",$JOB,DDF(DFL),W))
GOTO NS
SET B=^(W)
SET DTN(DTL)=$PIECE(B,U,2)
+4 IF '$TEST
SET B=A
SET DTN(DTL)=DFN(DFL)
+5 SET X=""
IF @("$D("_DTO(DTL)_"DTN(DTL)))#2")
SET X=^(DTN(DTL))
+6 IF 'B
Begin DoDot:1
+7 SET W=$EXTRACT(B,2,9)
SET B=$PIECE(B,",",2)
+8 IF $EXTRACT(X,+W,B)'?." "&DKP
if $GET(DIFRFRV)
DO KFRV1
QUIT
+9 SET %=$EXTRACT(X,B+1,999)
SET V=W-$LENGTH(X)-1
SET ^(DTN(DTL))=$EXTRACT(X,0,W-1)_$JUSTIFY("",$SELECT(V>0:V,1:0))_Y
if %'?." "
SET ^(DTN(DTL))=^(DTN(DTL))_$JUSTIFY("",B+1-W-$LENGTH(Y))_%
+10 IF $GET(DIFRFRV)
DO SFRVL
+11 QUIT
End DoDot:1
GOTO NS
+12 IF DKP
IF $PIECE(X,U,B)]""
if $GET(DIFRFRV)
DO KFRV1
GOTO NS
P SET $PIECE(^(DTN(DTL)),U,B)=Y
if $GET(DIFRFRV)
DO SFRVL
GOTO NS
+1 ;
1 if $ORDER(^(DFN(DFL),0))'>0
GOTO N
SET Z=$ORDER(^DD(DDF(DFL),"GL",DFN(DFL),0,0))
if Z'>0
GOTO N
IF DTO
if '$DATA(^UTILITY("DITR",$JOB,DDF(DFL),Z))
GOTO N
SET B=^(Z)
+1 DO D
SET Y=$PIECE(^DD(DDF(DFL-1),Z,0),U,2)
SET DDF(DFL+1)=+Y
IF DTO
SET Y=$PIECE(B,U,3)
SET X=""""_$PIECE(B,U,2)_""","
+2 SET DDT(DTL)=+Y
SET DTO(DTL)=DTO(DTL-1)_X
if $GET(DIFRDKP)
SET DIFRX=$DATA(@DIFRSA@("^DD",DIFRFILE,+Y))
IF @("'$D("_DTO(DTL)_"0))")
if $GET(DIFRDKP)
if DIFRX
GOTO LOOP
SET ^(0)=U_Y
+3 GOTO N
+4 ;
SFRV1 SET DIFRFRV1=$PIECE($NAME(@("DIFRFRV(D0,"_$PIECE(DFR(DFL),DFR(1),2,255)_""""_DFN(DFL)_""")")),"DIFRFRV(",2,255)
SET $EXTRACT(DIFRFRV1,$LENGTH(DIFRFRV1))=""
+1 QUIT
SFRVL if '$DATA(@DIFRSA@("FRV1",DIFRFILE,DIFRFRV1))
QUIT
+1 SET @DIFRSA@("FRVL",DIFRFILE,DIFRFRV1)=$NAME(@(DTO(DTL)_""""_DFN(DFL)_""")"))
+2 QUIT
KFRV1 KILL @DIFRSA@("FRV1",DIFRFILE,DIFRFRV1,B)
+1 QUIT
+2 ;
D SET DTL=DFL+1
+1 SET X=""""_DFN(DFL)_""","
SET DFR(DFL+1)=DFR(DFL)_X
SET DFL=DFL+1
SET DFN(DFL)=0
QUIT
+2 ;
F ;
+1 SET A=1
SET @("Z="_DIK_"D0,0)")
WRITE !,$PIECE(^(0),U,1)
if 'DTO!'$DATA(DITF)
GOTO I
+2 SET Z=$PIECE(DITF,";",1)
IF Z=" "
SET Z=D0
GOTO I
+3 if '$DATA(^(Z))
QUIT
SET X=$PIECE(DITF,";",2)
IF X
SET Z=$PIECE(^(Z),U,X)
GOTO I
+4 SET Z=$EXTRACT(^(Z),+$EXTRACT(X,2,9),+$PIECE(X,",",2))
I ;
+1 SET DFL=0
SET DTL=0
SET DA=D0
DO ^DITR1
+2 IF A
if $GET(DIFRSA)]""
DO ERR
QUIT
+3 IF $GET(DIFRSA)]""
SET DIFRND0=Y
IF 'DKP
IF @("$D("_DTO(DTL)_"Y))")
DO KILLIDX
GO ;
+1 SET DFL=1
SET DTL=1
SET DFN(1)=-1
DO N
+2 QUIT
+3 ;
KILLIDX ; Kill the old index for single entry (overwrite mode only).
+1 NEW DIK,DA,%,A,B
SET DA=Y
SET DIK=DTO(DTL)
SET DIK(0)="ABs"
+2 ;GET SUBSCRIPTED VALUES OF DA --GFT
SET A=$$CREF^DILF(DIK)
SET A=$NAME(@A)
SET B=$QLENGTH(A)-1
FOR %=1:1:DFL\2
SET DA(%)=$QSUBSCRIPT(A,B)
SET B=B-2
+3 NEW D0,DDF,DDT,DFL,DFR,DINUM,DTL,DTN,DTO,I,W,X,Y,Z
+4 DO IX2^DIK
QUIT
+5 ;
ERR NEW DIPAR
SET DIPAR(.01)=X
SET DIPAR("IEN")=Y
SET DIPAR("FILE")=DDT(DFL)
+1 DO BLD^DIALOG(9513.1,.DIPAR)
QUIT
+2 ;
