DITC1 ;SFISC/XAK-COMPARE FILE ENTRIES PRINT ;7/1/93 4:31 PM
;;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.
;
PRNT S %ZIS("B")="",%ZIS=$S($D(DIMERGE):"M",1:"QM") D ^%ZIS G:POP END^DITC I $D(IO("Q")) G QUE
COMP W:$D(DDSP) !,"COMPARING THE TWO ENTRIES" F I=1:1:2 I $L(DTO(I)) S J=-1 F K=0:0 S @("J=$O("_DTO(I)_"J))") Q:J="" W:$D(DDSP) "." D EACH
D DISP
Q
EACH ;
I @("$D("_DTO(I)_"J))'<10") D MUL Q
S X=^(J) F N=1:1 D:$L($P(X,U,N)) SETU Q:'$L($P(X,U,N,999))
Q
SETU ;
I '$D(^UTILITY($J,"DIT",J,N,0)) S @("Y=$O(^DD("_DFF_",""GL"",J,"_N_",-1))") Q:Y="" S %=^DD(DFF,Y,0),^UTILITY($J,"DIT",J,N,0)=Y_U_$P(%,U,1)_U I Y=.01,$P(%,U,5,999)["DINUM" S ^UTILITY($J,"DITDINUM",J,N,0)=""
S O=+^UTILITY($J,"DIT",J,N,0) S:$P(^DD(DFF,O,0),U,2)["O" ^UTILITY($J,"DITI",J,N,I)=$P(X,U,N)
S C=^DD(DFF,O,0),O=$P(C,U,1),C=$P(C,U,2),D0=DIT(I),Y=$P(X,U,N) D Y^DIQ S ^UTILITY($J,"DIT",J,N,I)=Y
Q
MUL ;
I '$D(^UTILITY($J,"DIT",U,J,0)) S @("Y=$O(^DD("_DFF_",""GL"",J,0,-1))") Q:Y="" S ^UTILITY($J,"DIT",U,J,0)=Y_U_$P(^DD(DFF,Y,0),U,1)_U
S N=0 F L=0:1 S @("N=$O("_DTO(I)_"J,N))") Q:'N
S $P(^UTILITY($J,"DIT",U,J,0),U,I+3)=L
Q
DISP ;
U IO
I $D(DIMERGE) S J=-1 F S J=$O(^UTILITY($J,"DIT",J)) Q:U[J S N=-1 F S N=$O(^UTILITY($J,"DIT",J,N)) Q:N="" D D11^DITC2
S DC=0,DDSH="",$P(DDSH,"-",IOM-1)="-",$P(DDSPC," ",30)=" ",DV=(IOM-1)\3
S DHD(0)="COMPARISON OF "_DFL(1)_" FILE ENTRIES"
S R=$S(DSUB(DSUB)[",":1,1:0),%H=$H D YX^%DTC S DHD(9)=$P(Y,":",1,2)
F I=1:1:2 I $L(DTO(I)) F J=1:2 S K=$P(DTO(I),",",1,J+R) Q:($E(K,$L(K))=",") D D0
S DIFF=$S(IOST?1"C".E:1,1:0) D ^DITC2 K DUOUT
I $D(DTOUT)!('$D(DIMERGE)) G EX
I IOST'?1"C".E W !!!!,?3,"**** NOW PROCEEDING WITH THE MERGE ****" W @IOF S DIACT="P" D ACT^DITC3 G EX
I X=U D ASK^DITC3 G EX
W ! D @($P("ASK",U,'$O(^UTILITY($J,"DIT",U,0)))_"^DITC3")
EX X $G(^%ZIS("C")) G END^DITC
Q
D0 ;
I '$D(^DD(DFF(J+1\2),.001,0)) S K=K_",0)" Q:'$D(@K) S Y=^(0),Y=$P(Y,U,1) Q:'$L(Y) S C=^DD(DFF(J+1\2),.01,0) G D01
S Y=$P($P(DTO(I),DIC,2),",",1),C=^DD(DFF(J+1\2),.001,0)
D01 S O=$P(C,U,1),C=$P(C,U,2) D Y^DIQ S $P(DHD(J\2+1),U,I)=Y
Q
QUE ;
K Y,K,L,M,N,I,X,X1,C,DDSP,DMSG
S DJ=0,DHD="COMPARE OF "_DFL(1)_" FILE" D ^DIP4 G END^DITC
Q
DQ ;
D NOW^%DTC S DT=X K %,%I G COMP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDITC1 2506 printed Dec 13, 2024@02:54:09 Page 2
DITC1 ;SFISC/XAK-COMPARE FILE ENTRIES PRINT ;7/1/93 4:31 PM
+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 ;
PRNT SET %ZIS("B")=""
SET %ZIS=$SELECT($DATA(DIMERGE):"M",1:"QM")
DO ^%ZIS
if POP
GOTO END^DITC
IF $DATA(IO("Q"))
GOTO QUE
COMP if $DATA(DDSP)
WRITE !,"COMPARING THE TWO ENTRIES"
FOR I=1:1:2
IF $LENGTH(DTO(I))
SET J=-1
FOR K=0:0
SET @("J=$O("_DTO(I)_"J))")
if J=""
QUIT
if $DATA(DDSP)
WRITE "."
DO EACH
+1 DO DISP
+2 QUIT
EACH ;
+1 IF @("$D("_DTO(I)_"J))'<10")
DO MUL
QUIT
+2 SET X=^(J)
FOR N=1:1
if $LENGTH($PIECE(X,U,N))
DO SETU
if '$LENGTH($PIECE(X,U,N,999))
QUIT
+3 QUIT
SETU ;
+1 IF '$DATA(^UTILITY($JOB,"DIT",J,N,0))
SET @("Y=$O(^DD("_DFF_",""GL"",J,"_N_",-1))")
if Y=""
QUIT
SET %=^DD(DFF,Y,0)
SET ^UTILITY($JOB,"DIT",J,N,0)=Y_U_$PIECE(%,U,1)_U
IF Y=.01
IF $PIECE(%,U,5,999)["DINUM"
SET ^UTILITY($JOB,"DITDINUM",J,N,0)=""
+2 SET O=+^UTILITY($JOB,"DIT",J,N,0)
if $PIECE(^DD(DFF,O,0),U,2)["O"
SET ^UTILITY($JOB,"DITI",J,N,I)=$PIECE(X,U,N)
+3 SET C=^DD(DFF,O,0)
SET O=$PIECE(C,U,1)
SET C=$PIECE(C,U,2)
SET D0=DIT(I)
SET Y=$PIECE(X,U,N)
DO Y^DIQ
SET ^UTILITY($JOB,"DIT",J,N,I)=Y
+4 QUIT
MUL ;
+1 IF '$DATA(^UTILITY($JOB,"DIT",U,J,0))
SET @("Y=$O(^DD("_DFF_",""GL"",J,0,-1))")
if Y=""
QUIT
SET ^UTILITY($JOB,"DIT",U,J,0)=Y_U_$PIECE(^DD(DFF,Y,0),U,1)_U
+2 SET N=0
FOR L=0:1
SET @("N=$O("_DTO(I)_"J,N))")
if 'N
QUIT
+3 SET $PIECE(^UTILITY($JOB,"DIT",U,J,0),U,I+3)=L
+4 QUIT
DISP ;
+1 USE IO
+2 IF $DATA(DIMERGE)
SET J=-1
FOR
SET J=$ORDER(^UTILITY($JOB,"DIT",J))
if U[J
QUIT
SET N=-1
FOR
SET N=$ORDER(^UTILITY($JOB,"DIT",J,N))
if N=""
QUIT
DO D11^DITC2
+3 SET DC=0
SET DDSH=""
SET $PIECE(DDSH,"-",IOM-1)="-"
SET $PIECE(DDSPC," ",30)=" "
SET DV=(IOM-1)\3
+4 SET DHD(0)="COMPARISON OF "_DFL(1)_" FILE ENTRIES"
+5 SET R=$SELECT(DSUB(DSUB)[",":1,1:0)
SET %H=$HOROLOG
DO YX^%DTC
SET DHD(9)=$PIECE(Y,":",1,2)
+6 FOR I=1:1:2
IF $LENGTH(DTO(I))
FOR J=1:2
SET K=$PIECE(DTO(I),",",1,J+R)
if ($EXTRACT(K,$LENGTH(K))=",")
QUIT
DO D0
+7 SET DIFF=$SELECT(IOST?1"C".E:1,1:0)
DO ^DITC2
KILL DUOUT
+8 IF $DATA(DTOUT)!('$DATA(DIMERGE))
GOTO EX
+9 IF IOST'?1"C".E
WRITE !!!!,?3,"**** NOW PROCEEDING WITH THE MERGE ****"
WRITE @IOF
SET DIACT="P"
DO ACT^DITC3
GOTO EX
+10 IF X=U
DO ASK^DITC3
GOTO EX
+11 WRITE !
DO @($PIECE("ASK",U,'$ORDER(^UTILITY($JOB,"DIT",U,0)))_"^DITC3")
EX XECUTE $GET(^%ZIS("C"))
GOTO END^DITC
+1 QUIT
D0 ;
+1 IF '$DATA(^DD(DFF(J+1\2),.001,0))
SET K=K_",0)"
if '$DATA(@K)
QUIT
SET Y=^(0)
SET Y=$PIECE(Y,U,1)
if '$LENGTH(Y)
QUIT
SET C=^DD(DFF(J+1\2),.01,0)
GOTO D01
+2 SET Y=$PIECE($PIECE(DTO(I),DIC,2),",",1)
SET C=^DD(DFF(J+1\2),.001,0)
D01 SET O=$PIECE(C,U,1)
SET C=$PIECE(C,U,2)
DO Y^DIQ
SET $PIECE(DHD(J\2+1),U,I)=Y
+1 QUIT
QUE ;
+1 KILL Y,K,L,M,N,I,X,X1,C,DDSP,DMSG
+2 SET DJ=0
SET DHD="COMPARE OF "_DFL(1)_" FILE"
DO ^DIP4
GOTO END^DITC
+3 QUIT
DQ ;
+1 DO NOW^%DTC
SET DT=X
KILL %,%I
GOTO COMP
