198 lines
8.2 KiB
Mathematica
198 lines
8.2 KiB
Mathematica
XDRMERGA ;SF-IRMFO.SEA/JLI - START OF NON-INTERACTIVE BATCH MERGE ;01/31/2000 09:14
|
|
;;7.3;TOOLKIT;**23,28,37,40,45**;Apr 25, 1995
|
|
;;
|
|
Q
|
|
APPROVE ; This is the entry point for approving a duplicate pair for merge
|
|
K DIRUT,DUOUT,DTOUT ;
|
|
D EN^XDRVCHEK ; update verified and/or ready to merge statuses if necessary
|
|
;
|
|
N XDRXX,XDRYY,XDRMA,DIE,DIC,DIR,DR,ZTDTH,ZTSK
|
|
N XDRX,XDRY,XDRFIL,XDRGLOB,X,Y,XDRNAME
|
|
N XDRFDA,XDRIENS,XDRI,XDRJ,XDRK,DA,DIK
|
|
;
|
|
S XDRFIL=$$FILE^XDRDPICK() Q:XDRFIL'>0
|
|
S XDRDIC=^DIC(XDRFIL,0,"GL")
|
|
S XDRGLOB=$E(XDRDIC,2,999)
|
|
S X=""
|
|
S XNCNT=0,XNCNT0=0
|
|
F S X=$O(^VA(15,"AVDUP",XDRGLOB,X)) Q:X="" S Y=$O(^(X,0)) D
|
|
. N YVAL S YVAL=^VA(15,Y,0)
|
|
. I $P(YVAL,U,20)>0 Q ; ALREADY DONE OR SCHEDULED
|
|
. I $P(YVAL,U,3)'="V" Q ; TAKE ONLY VERIFIED
|
|
. I $P(YVAL,U,5)'=1 Q ; TAKE ONLY IF MARKED READY TO MERGE
|
|
. I $P(YVAL,U,4)="" D Q ; MAKE SURE MERGE DIRECTION IS DEFINED
|
|
. . W !,"Entry `",Y," DOES NOT HAVE MERGE DIRECTION DEFINED - CAN'T APPROVE"
|
|
. . N XDRDICA S XDRDICA=U_$P($P(YVAL,U),";",2)
|
|
. . I '$D(@(XDRDICA_(+YVAL)_",0)"))!$D(@(XDRDICA_(+YVAL)_",-9)"))!'$D(@(XDRDICA_(+$P(YVAL,U,2))_",0)"))!$D(@(XDRDICA_(+$P(YVAL,U,2))_",-9)")) D Q
|
|
. . . D RESET^XDRDPICK(Y)
|
|
. I $P(YVAL,U,13)'>0 D
|
|
. . I $P(YVAL,U,4)'=2 S XDRY(+YVAL,+$P(YVAL,U,2))=Y
|
|
. . E S XDRY(+$P(YVAL,U,2),+YVAL)=Y
|
|
. . S XNCNT0=XNCNT0+1
|
|
I XNCNT0>0 W !!,XNCNT0," Entries are awaiting approval for merging Return to continue..." R X:DTIME
|
|
I $D(XDRY) D CHKBKUP I $D(DUOUT)!$D(DTOUT) Q
|
|
K XDRY
|
|
Q
|
|
;
|
|
STOP ;
|
|
N XDRI,DIE,DA,DR,DIR,XDRC
|
|
S XDRC=0 F XDRI=0:0 S XDRI=$O(^VA(15.2,XDRI)) Q:XDRI'>0 I $P(^(XDRI,0),U,4)="A" D
|
|
. S XDRC=XDRC+1
|
|
. S DIR(0)="Y",DIR("A")="Do you want to stop "_$P(^VA(15.2,XDRI,0),U)
|
|
. D ^DIR K DIR I Y'>0 Q
|
|
. S DIE="^VA(15.2,",DA=XDRI,DR=".09///1" D ^DIE
|
|
. K DIE,DR
|
|
I XDRC'>0 W !!,$C(7),"No active merge processes were found.",!!
|
|
Q
|
|
;
|
|
CHKBKUP ; Check if backups have been generated for outstanding pairs
|
|
N I,J,X,Y,X1,X2,XNCNT,I,J,K,L,M,N,XX
|
|
K DIR
|
|
;S DIR("A")="Do you want to check pairs awaiting backups (Y/N)"
|
|
;S DIR("?")="Indication that a backup of the data for the entries for a duplicate pair is required prior to merging the entries. You may review entries to see if any should be marked as completed."
|
|
;S DIR(0)="Y" D ^DIR K DIR Q:Y'>0
|
|
S ASKNAME="ASK1" D CHECK
|
|
Q
|
|
;
|
|
CHECK ;
|
|
W @IOF
|
|
S XNCNT=0
|
|
F I=0:0 S I=$O(XDRY(I)) Q:I'>0 D Q:$D(DUOUT)!$D(DTOUT)
|
|
. F J=0:0 S J=$O(XDRY(I,J)) Q:J'>0 D Q:$D(DUOUT)!$D(DTOUT)
|
|
. . S X01=$G(@(XDRDIC_I_",0)")),X1=$P(X01,U),X1S=$P(X01,U,9),X1S=$E(X1S,1,3)_"-"_$E(X1S,4,5)_"-"_$E(X1S,6,15)
|
|
. . S X02=$G(@(XDRDIC_J_",0)")),X2=$P(X02,U),X2S=$P(X02,U,9),X2S=$E(X2S,1,3)_"-"_$E(X2S,4,5)_"-"_$E(X2S,6,15)
|
|
. . I X1=""!(X2="") K XDRY(I,J) Q
|
|
. . F Q:X1'["MERGING INTO" S X1=$P($P(X1,"(",2,10),")",1,$L(X1,")")-1)
|
|
. . S XNCNT=XNCNT+1,XX(XNCNT)=I_U_J
|
|
. . W !!,$J(XNCNT,3)," ",?8,X1,?42,X1S,?60,"[",I,"]"
|
|
. . W !,?8,X2,?42,X2S,?60,"[",J,"]"
|
|
. . I '(XNCNT#6) D @ASKNAME Q:$D(DUOUT)!$D(DTOUT) W @IOF
|
|
I '($D(DUOUT)!$D(DTOUT)) D @ASKNAME
|
|
Q
|
|
;
|
|
ASK1 ;
|
|
W ! S DIR(0)="LO^1:"_XNCNT,DIR("A")="Select entries to approve them for merging"
|
|
;W !,"TEST"
|
|
D ^DIR K DIR K DIRUT Q:$D(DUOUT)!$D(DTOUT)
|
|
S K="" F S K=$O(Y(K)) Q:K="" S Y=Y(K) K Y(K) D
|
|
. F M=1:1 S N=$P(Y,",",M) Q:N="" D
|
|
. . S N1=+XX(N),N2=$P(XX(N),U,2)
|
|
. . S (DA,XDRX(N1,N2))=XDRY(N1,N2)
|
|
. . N I,J,K,M,N,N1,N2,X1,X2,X,DIE,DR,Y
|
|
. . S DIE="^VA(15,"
|
|
. . S X=DT,X=$$FMTE^XLFDT(X,"2D")
|
|
. . S X=$P($P(^VA(200,DUZ,0),U),",",2)_" "_$P($P(^(0),U),",")_" (DUZ="_DUZ_") "_X
|
|
. . S DR=".13///1;.14///"_X
|
|
. . D ^DIE
|
|
Q
|
|
;
|
|
RESTART ; Entry point to restart non-completed merges
|
|
N NC,N S NC=0
|
|
F XDRFDA=0:0 S XDRFDA=$O(^VA(15.2,XDRFDA)) Q:XDRFDA'>0 D
|
|
. S X=$P(^VA(15.2,XDRFDA,0),U,4) I X="C"!(X="A") S N=1 D Q:N=1
|
|
. . F J=0:0 S J=$O(^VA(15.2,XDRFDA,3,J)) Q:J'>0 I "CA"'[$P(^(J,0),U,3) S N=0 Q
|
|
. S NC=NC+1
|
|
. S DIR(0)="Y",DIR("A")="Do you want to RESTART merge process "_$P(^VA(15.2,XDRFDA,0),U),DIR("B")="NO"
|
|
. D ^DIR K DIR Q:Y'>0
|
|
. S ZTRTN="DQ^XDRMERG0",ZTSAVE("XDRFDA")="",ZTIO="NULL"
|
|
. D ^%ZTLOAD I '$D(ZTSK) W !!,$C(7),"RESTART **NOT** QUEUED" Q
|
|
. S $P(^VA(15.2,XDRFDA,0),U,8,9)=ZTSK_U ; SET TASK NUMBER AND REMOVE HALT FLAG IF SET
|
|
. W !,"Restart queued as task ",ZTSK,!
|
|
I NC'>0 W !!,$C(7),"No merge processes found that needed restarting.",!!
|
|
Q
|
|
;
|
|
;
|
|
DOSUBS(XDRFROM,XDRTO,IENTOSTR,XDRDASEQ) ;
|
|
N NODEA,SFILE,VALUE,XVALUE,XDRXX,XDRYY,YVALUE,XENTOSTR
|
|
N XDRAA,XDRZZ ; DEBUG STATEMENT
|
|
S SFILE=+$P($G(@(XDRFROM_"0)")),U,2)
|
|
I SFILE'>0 Q ; NO FILE NUMBER, NOT FILE MANAGER COMPATIBLE
|
|
I $P($G(^DD(SFILE,.01,0)),U,2)["W" D Q ; HANDLE WORD PROCESSING FIELDS
|
|
. N XF,XT S XT=$E(XDRTO,1,$L(XDRTO)-1)_")"
|
|
. I '$D(@XT) D
|
|
. . S XF=$E(XDRFROM,1,$L(XDRFROM)-1)_")"
|
|
. . M @XT=@XF
|
|
. . Q
|
|
. Q
|
|
F NODEA=0:0 S NODEA=$O(@(XDRFROM_NODEA_")")) Q:NODEA'>0 D
|
|
. S VALUE=$P($G(@(XDRFROM_NODEA_",0)")),U) ; GET .01 VALUE
|
|
. N XDRDT S XDRDT=^DD(SFILE,.01,0)
|
|
. I $P(XDRDT,U,2)["D" S XDRDT=$P(XDRDT,U,5,999),XDRDINUM=$S(XDRDT["DINUM":1,1:0) I XDRDINUM S XDRDT=0 D DINUMDAT Q:XDRDT ; HANDLE DINUMED DATES BY SIMPLY MOVING THEM
|
|
. S YVALUE=0,XVALUE=0 I $D(^DD(SFILE,.001,0)) S YVALUE=NODEA I $D(@(XDRTO_NODEA_")")) S XVALUE=YVALUE
|
|
. I XVALUE=0,$P(^DD(SFILE,.01,0),U,5,99)["DINUM",$D(@(XDRTO_NODEA_")")) S XVALUE=NODEA
|
|
. I XVALUE=0 S XVALUE=+$$FIND1^DIC(SFILE,(","_IENTOSTR),"Q",VALUE) ; FIND CURRENT ENTRY NUMBER, IF PRESENT
|
|
. I XVALUE>0 D Q ; SUBFILE EXISTS IN IENTO, CHECK FOR LOWER SUBFILES
|
|
. . N X,X1,NODE,NEWFROM,NEWTO,NEWTOIEN
|
|
. . S NODE=""
|
|
. . F S NODE=$O(@(XDRFROM_NODEA_","""_NODE_""")")) Q:NODE="" D
|
|
. . . I $D(@(XDRFROM_NODEA_","""_NODE_""")"))'>1 Q
|
|
. . . S NEWFROM=XDRFROM_NODEA_","""_NODE_""","
|
|
. . . S NEWTO=XDRTO_XVALUE_","""_NODE_""","
|
|
. . . S NEWTOIEN=XVALUE_","_IENTOSTR
|
|
. . . D DOSUBS(NEWFROM,NEWTO,NEWTOIEN,(XVALUE_U_XDRDASEQ))
|
|
. K XDRYY I YVALUE>0 S XDRYY(1)=YVALUE
|
|
. S XENTOSTR="+1,"_IENTOSTR
|
|
. S XDRFILTY=$P($G(^DD(SFILE,.01,0)),U,2)
|
|
. I XDRFILTY["P" S VALUE="`"_VALUE
|
|
. I XDRFILTY["V" D
|
|
. . N Y S Y=$P(VALUE,";",2) Q:Y=""
|
|
. . S Y=$P($G(@("^"_Y_"0)")),U) Q:Y=""
|
|
. . S VALUE=Y_".`"_(+VALUE)
|
|
. . Q
|
|
. I SFILE=70.03 S XDRFILTY="D" ;use internal data for file 70.03
|
|
. I XDRFILTY'["P"&(XDRFILTY'["V"),XDRFILTY'["D" S VALUE=$$GETEXT(XDRFROM,NODEA,SFILE)
|
|
. S XDRXX(SFILE,XENTOSTR,.01)=VALUE
|
|
. I $O(^DD(SFILE,0,"ID",0))>0 D
|
|
. . ;CODE FOR ADDING IDENTIFIERS
|
|
. . N I,N,XDRFROM1,IENFR
|
|
. . S N=0,I=SFILE F S I=$G(^DD(I,0,"UP")) Q:I'>0 S N=N+1
|
|
. . S XDRFROM1=$P(XDRFROM,"(",2,99),IENFR=NODEA_","
|
|
. . F I=$L(XDRFROM1,",")-2:-2 Q:N'>0 S IENFR=IENFR_$P(XDRFROM1,",",I)_",",N=N-1
|
|
. . ;
|
|
. . F XDRID=0:0 S XDRID=$O(^DD(SFILE,0,"ID",XDRID)) Q:XDRID'>0 D
|
|
. . . S N=$$GET1^DIQ(SFILE,IENFR,XDRID)
|
|
. . . I N'="" S XDRXX(SFILE,XENTOSTR,XDRID)=N
|
|
. . . Q
|
|
. . Q
|
|
. ;
|
|
. K XDRAA,XDRZZ I $D(XDRTESTK) M XDRAA=XDRXX ; DEBUG STATEMENT
|
|
. ; DATES THAT ARE DINUMED HAVE BEEN HANDLED ABOVE, SO CAN PASS A DATE IN AS AN INTERNAL VALUE
|
|
. D UPDATE^DIE($S(XDRFILTY["D":"",1:"E"),"XDRXX","XDRYY","XDRZZ") ; CREATE A NEW ENTRY IN IENTO FOR VALUE
|
|
. I $D(XDRZZ),$D(XDRTESTK),SFILE'=2.0361 S XDRTESTK=XDRTESTK+1 M ^XTMP("XDRTESTK",$$NOW^XLFDT(),XDRTESTK,"XX")=XDRAA,^("ZZ")=XDRZZ ; DEBUG STATEMENT
|
|
. S NODEB=$G(XDRYY(1)) I NODEB'>0 Q
|
|
. M @(XDRTO_NODEB_")")=@(XDRFROM_NODEA_")")
|
|
. S DIK=XDRTO,DA=NODEB D
|
|
. . F I=1:1 S DA(I)=$P(XDRDASEQ,U,I) I DA(I)="" K DA(I) Q
|
|
. I SFILE=55.06 N DIU S DIU(0)=1 F DIK(1)=".01^B","10^AUDS","34^AUD","64^AUDDD","7^ACR1" D EN1^DIK
|
|
. I SFILE'=55.06 N DIU S DIU(0)=1 D IX^DIK
|
|
Q
|
|
;
|
|
GETEXT(DICA,DA,FILNUM) ; GET EXTERNAL VALUE FOR .01 FIELD
|
|
N DIC,DIQ,DR,XDRQ
|
|
S DIC=DICA,DIC("P")=FILNUM,DR=.01,DIQ="XDRQ",DIQ(0)="E"
|
|
D EN^DIQ1
|
|
Q $G(XDRQ(FILNUM,DA,.01,"E"))
|
|
;
|
|
DINUMDAT ; PROCESS ENTRIES WITH SAMPLE DATE/TIMES WITH SECONDS, NEEDS DINUM
|
|
N NEWVAL,NODETO
|
|
S NODETO=NODEA
|
|
I $D(@(XDRTO_NODEA_")")) Q:(SFILE'=63.04) D
|
|
. S NEWVAL=VALUE
|
|
. F Q:'$D(@(XDRTO_NODETO_")")) S NODETO=NODETO-.000001,NEWVAL=NEWVAL+.000001
|
|
M @(XDRTO_NODETO_")")=@(XDRFROM_NODEA_")")
|
|
I $D(NEWVAL) S $P(@(XDRTO_NODETO_",0)"),U)=NEWVAL
|
|
S DIK=XDRTO,DA=NODEA D D IX^DIK
|
|
. F I=1:1 S DA(I)=$P(XDRDASEQ,U,I) I DA(I)="" K DA(I) Q
|
|
S XDRDT=1
|
|
Q
|
|
;
|
|
DODIS ; CODE TO HANDLE DISPOSITION ENTRIES IN PATIENT FILE
|
|
N XDRI,DA,DIK
|
|
F XDRI=0:0 S XDRI=$O(@(XDRDIC_IENFROM_",""DIS"","_XDRI_")")) Q:XDRI'>0 D
|
|
. I $D(@(XDRDIC_IENTO_",""DIS"","_XDRI_")")) Q
|
|
. M @(XDRDIC_IENTO_",""DIS"","_XDRI_")")=@(XDRDIC_IENFROM_",""DIS"","_XDRI_")")
|
|
. S DA=XDRI,DA(1)=IENTO,DIK=XDRDIC_IENTO_",""DIS""," D IX^DIK
|
|
. Q
|
|
Q
|
|
;
|