DITM1 ;SFISC/JCM(OHPRD)-ASKS SUBFILE FOR COMPARE AND MERGE ;2/24/93 14:00
;;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.
;
; When subfiles work will need to delete SUB+0 and uncomment SUB+1
;--------------------------------------------------------------------
START ;
SUB S L=L+1,DFL(L)=$O(^DD(+Y,0,"NM","")),(DFF,DFF(L))=+Y
;S %=$P(Y,U,2),Y=+Y D SUB^DICRW K DIA S:Y>0 DITM("SUBFILE")=+Y
ENTR I $D(DTOUT)!(X["^") S DITM("QFLG")="" G END
K DIC S DIC(0)="AEQMZ",DIC=DSUB(0),DFL=1,DIT=DIT+1,DIT(DIT)="" W:DIT=1 !
E1 S DIC("A")=$E(" ",1,DFL-1*3)_$S(DIT=2:" WITH ",1:"COMPARE ")_DFL(DFL)_": " I (DIT=2),(DFL=L),($P(DIT(1),",",1,L-1)=$P(DIT(2),",",1,L-1)) S DIC("S")="I Y-"_$P(DIT(1),",",L)
D ^DIC K DIC("S"),DIC("A") I Y>0,$D(DSUB(DFL)),$D(DFL(DFL+1)) S DIC=DIC_+Y_","_DSUB(DFL),DIT(DIT)=DIT(DIT)_+Y_",",DFL=DFL+1 S %=$O(@(DIC_""""")")) G:%'=""&'% E1 S:%>0 ^(0)=U_DFF_U I %="" W !,"NO "_DFL(DFL) S (%,Y)=-1
S:X=U DITM("QFLG")="" G:X=U!(Y=-1) END S DTO(DIT)=DIC_+Y_",",DTO(DIT,"X")=Y(0,0),DIT(DIT)=DIT(DIT)_+Y G:DIT=1 ENTR S DDSP=1
S DITM("DFF")=DFF,DITM("DIT(1)")=DIT(1),DITM("DIT(2)")=DIT(2)
S DITM("DIC")=DSUB(0)
I $D(DITM("SUB FILE")),$D(DSUB(1)) S DITM("DSUB1")=$P(DSUB(1),",",1)
END ;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDITM1 1484 printed Dec 13, 2024@02:54:17 Page 2
DITM1 ;SFISC/JCM(OHPRD)-ASKS SUBFILE FOR COMPARE AND MERGE ;2/24/93 14:00
+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 ; When subfiles work will need to delete SUB+0 and uncomment SUB+1
+8 ;--------------------------------------------------------------------
START ;
SUB SET L=L+1
SET DFL(L)=$ORDER(^DD(+Y,0,"NM",""))
SET (DFF,DFF(L))=+Y
+1 ;S %=$P(Y,U,2),Y=+Y D SUB^DICRW K DIA S:Y>0 DITM("SUBFILE")=+Y
ENTR IF $DATA(DTOUT)!(X["^")
SET DITM("QFLG")=""
GOTO END
+1 KILL DIC
SET DIC(0)="AEQMZ"
SET DIC=DSUB(0)
SET DFL=1
SET DIT=DIT+1
SET DIT(DIT)=""
if DIT=1
WRITE !
E1 SET DIC("A")=$EXTRACT(" ",1,DFL-1*3)_$SELECT(DIT=2:" WITH ",1:"COMPARE ")_DFL(DFL)_": "
IF (DIT=2)
IF (DFL=L)
IF ($PIECE(DIT(1),",",1,L-1)=$PIECE(DIT(2),",",1,L-1))
SET DIC("S")="I Y-"_$PIECE(DIT(1),",",L)
+1 DO ^DIC
KILL DIC("S"),DIC("A")
IF Y>0
IF $DATA(DSUB(DFL))
IF $DATA(DFL(DFL+1))
SET DIC=DIC_+Y_","_DSUB(DFL)
SET DIT(DIT)=DIT(DIT)_+Y_","
SET DFL=DFL+1
SET %=$ORDER(@(DIC_""""")"))
if %'=""&'%
GOTO E1
if %>0
SET ^(0)=U_DFF_U
IF %=""
WRITE !,"NO "_DFL(DFL)
SET (%,Y)=-1
+2 if X=U
SET DITM("QFLG")=""
if X=U!(Y=-1)
GOTO END
SET DTO(DIT)=DIC_+Y_","
SET DTO(DIT,"X")=Y(0,0)
SET DIT(DIT)=DIT(DIT)_+Y
if DIT=1
GOTO ENTR
SET DDSP=1
+3 SET DITM("DFF")=DFF
SET DITM("DIT(1)")=DIT(1)
SET DITM("DIT(2)")=DIT(2)
+4 SET DITM("DIC")=DSUB(0)
+5 IF $DATA(DITM("SUB FILE"))
IF $DATA(DSUB(1))
SET DITM("DSUB1")=$PIECE(DSUB(1),",",1)
END ;
+1 QUIT
