XDRVCHEK ;SF-IRMFO.SEA/JLI - CHECK FOR ENTRIES WHICH HAVE PASSED THE NUMBER OF DAYS REQUIRED FOR VERIFICATION ;02/24/2000 07:46
;;7.3;TOOLKIT;**23,46**;Apr 25, 1995
;;
;;
EN ;
N XDRDAYS,XDRGLB,XDRI,XDRJ,XDRK,XDRX,DIE,DA,DR,XDRDA,XDRXREF
F XDRI=0:0 S XDRI=$O(^VA(15.1,XDRI)) Q:XDRI'>0 D
. S XDRGLB=$P(^DIC(XDRI,0,"GL"),U,2)
. S XDRDAYS=$P(^VA(15.1,XDRI,0),U,13)
. F XDRXREF="AXDUP","ARDUP1" F XDRJ=0:0 S XDRJ=$O(^VA(15,XDRXREF,XDRGLB,XDRJ)) Q:XDRJ'>0 D
. . S XDRX=$P(^VA(15,XDRJ,0),U,7)
. . I XDRX>0,$$FMDIFF^XLFDT(DT,XDRX)'<XDRDAYS D FINALVER(XDRJ)
D CHKREADY
Q
FINALVER(XDRDA) ;
N XDRFDA,X,XDRX1,XDRX2,NAME,FILE
S XDRFDA=$$FIND1^DIC(15.02,","_XDRDA_",","X","PRIMARY")
S X=$S(XDRFDA>0:^VA(15,XDRDA,2,XDRFDA,0),1:"") Q:X=""
I $P(X,U,2)'="V" Q
S XDRFDA(15,XDRDA_",",.04)=$P(X,U,5) Q:$P(X,U,5)'>0
D FILE^DIE("","XDRFDA") K XDRFDA ; SET DIRECTION IN BEFORE SETTING STATUS
S FILE=$P($P(^VA(15,XDRDA,0),U),";",2),FILE=+$P(@(U_FILE_"0)"),U,2)
S XDRX1="V" F XDRFDA=0:0 S XDRFDA=$O(^VA(15.1,FILE,2,XDRFDA)) Q:XDRFDA'>0 S NAME=$P(^(XDRFDA,0),U) S NAME=$$FIND1^DIC(15.02,","_XDRDA_",","X",NAME) I NAME'>0 S XDRX1="R" Q
;S XDRX1="V" F XDRFDA=0:0 S XDRFDA=$O(^VA(15,XDRDA,2,XDRFDA)) Q:XDRFDA'>0 I $P(^(XDRFDA,0),U,2)'="V",$P(^(0),U,2)'="D" S XDRX1="R" Q
K XDRFDA S XDRFDA(15,XDRDA_",",.03)=XDRX1
I XDRX1="V" D
. S XDRFDA(15,XDRDA_",",.07)=($$NOW^XLFDT()\1)
. S XDRFDA(15,XDRDA_",",.11)=$S(X'="":$P(X,U,3),1:DUZ)
D FILE^DIE("","XDRFDA")
I XDRX1'="V" Q
NAME ;
S X=^VA(15,XDRDA,0)
I $P(X,U,4)=2 D
. S XDRX1=+$P(X,U,2)
. S XDRX2=+$P(X,U)
E D
. S XDRX1=+$P(X,U)
. S XDRX2=+$P(X,U,2)
S X=U_$P($P(X,U),";",2)_"XDRX1,0)"
S NAME=$P(@X,U)
F Q:NAME'["MERGING INTO" S NAME=$P($P(NAME,"(",2,10),")",1,$L(NAME,")")-1)
S NAME="MERGING INTO `"_XDRX2_" USE THAT ENTRY ("_NAME_")"
S $P(@X,U)=NAME
Q
;
CHKREADY ; Check whether the status with respect to merge can be changed
; from NOT READY to READY based on the minimum number of days prior to
; merging
;
F XDRFILE=0:0 S XDRFILE=$O(^VA(15.1,XDRFILE)) Q:XDRFILE'>0 D
. S XDRGLOB=$P(^DIC(XDRFILE,0,"GL"),U,2)
. S XDRDAYS=+$P($G(^VA(15.1,XDRFILE,0)),U,14)
. S XDRDAYS=$S(XDRDAYS>0:XDRDAYS,1:-1)
. S XDRDATE=$$FMADD^XLFDT(DT,-XDRDAYS)
. S XDRI="" F S XDRI=$O(^VA(15,"AVDUP",XDRGLOB,XDRI)) Q:XDRI="" D
. . S XDRJ=$O(^VA(15,"AVDUP",XDRGLOB,XDRI,0))
. . S XDRJV=$G(^VA(15,XDRJ,0)) I XDRJV="" K ^VA(15,"AVDUP",XDRGLOB,XDRI,XDRJ) Q
. . I $P(XDRJV,U,5)<2,$P(XDRJV,U,7)<XDRDATE D
. . . S DIE=15,DA=XDRJ,DR=".05///1;" D ^DIE K DIE,DA,DR
;
CLEAN ;
N I,J,X,Y
F I=0:0 S I=$O(^VA(15,I)) Q:I'>0 D
. S V=$G(^VA(15,I,0)) I $P(V,U,3)'="V" Q
. S Y=$P(V,U,4)
. S Y=$S(Y>0:Y,1:1)
. S X=$P(V,U,Y)
. F J=0:0 S J=$O(^VA(15,"B",X,J)) Q:J'>0 I J'=I D
. . S Y=$P($G(^VA(15,J,0)),U,3)
. . I Y="P"!(Y="") D
. . . S DA=J
. . . N I,J,X,Y,V
. . . S DIK="^VA(15,"
. . . D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRVCHEK 2922 printed Dec 13, 2024@02:39:54 Page 2
XDRVCHEK ;SF-IRMFO.SEA/JLI - CHECK FOR ENTRIES WHICH HAVE PASSED THE NUMBER OF DAYS REQUIRED FOR VERIFICATION ;02/24/2000 07:46
+1 ;;7.3;TOOLKIT;**23,46**;Apr 25, 1995
+2 ;;
+3 ;;
EN ;
+1 NEW XDRDAYS,XDRGLB,XDRI,XDRJ,XDRK,XDRX,DIE,DA,DR,XDRDA,XDRXREF
+2 FOR XDRI=0:0
SET XDRI=$ORDER(^VA(15.1,XDRI))
if XDRI'>0
QUIT
Begin DoDot:1
+3 SET XDRGLB=$PIECE(^DIC(XDRI,0,"GL"),U,2)
+4 SET XDRDAYS=$PIECE(^VA(15.1,XDRI,0),U,13)
+5 FOR XDRXREF="AXDUP","ARDUP1"
FOR XDRJ=0:0
SET XDRJ=$ORDER(^VA(15,XDRXREF,XDRGLB,XDRJ))
if XDRJ'>0
QUIT
Begin DoDot:2
+6 SET XDRX=$PIECE(^VA(15,XDRJ,0),U,7)
+7 IF XDRX>0
IF $$FMDIFF^XLFDT(DT,XDRX)'<XDRDAYS
DO FINALVER(XDRJ)
End DoDot:2
End DoDot:1
+8 DO CHKREADY
+9 QUIT
FINALVER(XDRDA) ;
+1 NEW XDRFDA,X,XDRX1,XDRX2,NAME,FILE
+2 SET XDRFDA=$$FIND1^DIC(15.02,","_XDRDA_",","X","PRIMARY")
+3 SET X=$SELECT(XDRFDA>0:^VA(15,XDRDA,2,XDRFDA,0),1:"")
if X=""
QUIT
+4 IF $PIECE(X,U,2)'="V"
QUIT
+5 SET XDRFDA(15,XDRDA_",",.04)=$PIECE(X,U,5)
if $PIECE(X,U,5)'>0
QUIT
+6 ; SET DIRECTION IN BEFORE SETTING STATUS
DO FILE^DIE("","XDRFDA")
KILL XDRFDA
+7 SET FILE=$PIECE($PIECE(^VA(15,XDRDA,0),U),";",2)
SET FILE=+$PIECE(@(U_FILE_"0)"),U,2)
+8 SET XDRX1="V"
FOR XDRFDA=0:0
SET XDRFDA=$ORDER(^VA(15.1,FILE,2,XDRFDA))
if XDRFDA'>0
QUIT
SET NAME=$PIECE(^(XDRFDA,0),U)
SET NAME=$$FIND1^DIC(15.02,","_XDRDA_",","X",NAME)
IF NAME'>0
SET XDRX1="R"
QUIT
+9 ;S XDRX1="V" F XDRFDA=0:0 S XDRFDA=$O(^VA(15,XDRDA,2,XDRFDA)) Q:XDRFDA'>0 I $P(^(XDRFDA,0),U,2)'="V",$P(^(0),U,2)'="D" S XDRX1="R" Q
+10 KILL XDRFDA
SET XDRFDA(15,XDRDA_",",.03)=XDRX1
+11 IF XDRX1="V"
Begin DoDot:1
+12 SET XDRFDA(15,XDRDA_",",.07)=($$NOW^XLFDT()\1)
+13 SET XDRFDA(15,XDRDA_",",.11)=$SELECT(X'="":$PIECE(X,U,3),1:DUZ)
End DoDot:1
+14 DO FILE^DIE("","XDRFDA")
+15 IF XDRX1'="V"
QUIT
NAME ;
+1 SET X=^VA(15,XDRDA,0)
+2 IF $PIECE(X,U,4)=2
Begin DoDot:1
+3 SET XDRX1=+$PIECE(X,U,2)
+4 SET XDRX2=+$PIECE(X,U)
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 SET XDRX1=+$PIECE(X,U)
+7 SET XDRX2=+$PIECE(X,U,2)
End DoDot:1
+8 SET X=U_$PIECE($PIECE(X,U),";",2)_"XDRX1,0)"
+9 SET NAME=$PIECE(@X,U)
+10 FOR
if NAME'["MERGING INTO"
QUIT
SET NAME=$PIECE($PIECE(NAME,"(",2,10),")",1,$LENGTH(NAME,")")-1)
+11 SET NAME="MERGING INTO `"_XDRX2_" USE THAT ENTRY ("_NAME_")"
+12 SET $PIECE(@X,U)=NAME
+13 QUIT
+14 ;
CHKREADY ; Check whether the status with respect to merge can be changed
+1 ; from NOT READY to READY based on the minimum number of days prior to
+2 ; merging
+3 ;
+4 FOR XDRFILE=0:0
SET XDRFILE=$ORDER(^VA(15.1,XDRFILE))
if XDRFILE'>0
QUIT
Begin DoDot:1
+5 SET XDRGLOB=$PIECE(^DIC(XDRFILE,0,"GL"),U,2)
+6 SET XDRDAYS=+$PIECE($GET(^VA(15.1,XDRFILE,0)),U,14)
+7 SET XDRDAYS=$SELECT(XDRDAYS>0:XDRDAYS,1:-1)
+8 SET XDRDATE=$$FMADD^XLFDT(DT,-XDRDAYS)
+9 SET XDRI=""
FOR
SET XDRI=$ORDER(^VA(15,"AVDUP",XDRGLOB,XDRI))
if XDRI=""
QUIT
Begin DoDot:2
+10 SET XDRJ=$ORDER(^VA(15,"AVDUP",XDRGLOB,XDRI,0))
+11 SET XDRJV=$GET(^VA(15,XDRJ,0))
IF XDRJV=""
KILL ^VA(15,"AVDUP",XDRGLOB,XDRI,XDRJ)
QUIT
+12 IF $PIECE(XDRJV,U,5)<2
IF $PIECE(XDRJV,U,7)<XDRDATE
Begin DoDot:3
+13 SET DIE=15
SET DA=XDRJ
SET DR=".05///1;"
DO ^DIE
KILL DIE,DA,DR
End DoDot:3
End DoDot:2
End DoDot:1
+14 ;
CLEAN ;
+1 NEW I,J,X,Y
+2 FOR I=0:0
SET I=$ORDER(^VA(15,I))
if I'>0
QUIT
Begin DoDot:1
+3 SET V=$GET(^VA(15,I,0))
IF $PIECE(V,U,3)'="V"
QUIT
+4 SET Y=$PIECE(V,U,4)
+5 SET Y=$SELECT(Y>0:Y,1:1)
+6 SET X=$PIECE(V,U,Y)
+7 FOR J=0:0
SET J=$ORDER(^VA(15,"B",X,J))
if J'>0
QUIT
IF J'=I
Begin DoDot:2
+8 SET Y=$PIECE($GET(^VA(15,J,0)),U,3)
+9 IF Y="P"!(Y="")
Begin DoDot:3
+10 SET DA=J
+11 NEW I,J,X,Y,V
+12 SET DIK="^VA(15,"
+13 DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
