XDRMPACK ;IHS/OHPRD/JCM - CHECKS PACKAGE FILE FOR SPECIAL MERGES; [ 08/13/92 09:50 AM ]
;;7.3;TOOLKIT;;Apr 25, 1995
START ;
I '$D(^DIC(9.4,"AMRG",XDRFL)) D STATUS G END
W:'$D(XDRM("NOTALK")) !!!,"I am now checking the different packages to see if they have data "
W:'$D(XDRM("NOTALK")) !,"for this record, I will also notify the packages about the merge"
W:'$D(XDRM("NOTALK")) !,"This may take awhile, please be patient.",!!
S XDRMPACK=""
LOOP ; Checks packages that affects patient merge and edits Merge Package
; mulitple of Duplicate Record file.
F XDRMI=0:0 S XDRMPACK=$O(^DIC(9.4,"AMRG",XDRFL,XDRMPACK)) Q:'XDRMPACK D PACKAGE ; Control point- gets packages that affect patient merge
K XDRMI
END D EOJ ;------->End of Job
Q
;
PACKAGE ; Checks packages that affects patient merge
;
I '$D(^VA(15,XDRMPDA,11,XDRMPACK)) D ADD I 1
E I $P(^VA(15,XDRMPDA,11,XDRMPACK,0),U,2)=2 D CHECK I XDRMPACK("STATUS")'=2 D EDIT
Q
ADD ;
S DIE=15,DA=XDRMPDA,DR="1101///`"_XDRMPACK
S DR(2,15.01101)=".02////"
D ^DIE K DIE,DR,DA
D CHECK
S DA(1)=XDRMPDA,DA=XDRMPACK
S DIE="^VA(15,"_DA(1)_",11,"
S DR=".02////"_XDRMPACK("STATUS")
D ^DIE K DIE,DR,DA
Q
CHECK ;
S XDRZ=0
I $D(^DIC(9.4,XDRMPACK,20,XDRFL,1)) X ^DIC(9.4,XDRMPACK,20,XDRFL,1)
S XDRMPACK("STATUS")=$S('XDRZ:2,1:0)
I XDRZ,$D(^DIC(9.4,XDRMPACK,20,XDRFL,0)),$P(^(0),U,3)]"" S XDRMPACK("STATUS")=1
K XDRZ
Q
EDIT ;
S DA(1)=XDRMPDA,DA=XDRMPACK
S DIE="^VA(15,"_DA(1)_",11,"
S DR=".02////"_XDRMPACK("STATUS")
D ^DIE K DIE,DR,DA
Q
;
STATUS ; Changes merge status field to ready if no packages affect merge
S DIE="^VA(15,",DA=XDRMPDA,DR=".05///1"
D ^DIE K DIE,DR,DA
Q
EOJ ; End of job and cleanup
K XDRMPACK,XDRMI
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRMPACK 1741 printed Dec 13, 2024@02:39:34 Page 2
XDRMPACK ;IHS/OHPRD/JCM - CHECKS PACKAGE FILE FOR SPECIAL MERGES; [ 08/13/92 09:50 AM ]
+1 ;;7.3;TOOLKIT;;Apr 25, 1995
START ;
+1 IF '$DATA(^DIC(9.4,"AMRG",XDRFL))
DO STATUS
GOTO END
+2 if '$DATA(XDRM("NOTALK"))
WRITE !!!,"I am now checking the different packages to see if they have data "
+3 if '$DATA(XDRM("NOTALK"))
WRITE !,"for this record, I will also notify the packages about the merge"
+4 if '$DATA(XDRM("NOTALK"))
WRITE !,"This may take awhile, please be patient.",!!
+5 SET XDRMPACK=""
LOOP ; Checks packages that affects patient merge and edits Merge Package
+1 ; mulitple of Duplicate Record file.
+2 ; Control point- gets packages that affect patient merge
FOR XDRMI=0:0
SET XDRMPACK=$ORDER(^DIC(9.4,"AMRG",XDRFL,XDRMPACK))
if 'XDRMPACK
QUIT
DO PACKAGE
+3 KILL XDRMI
END ;------->End of Job
DO EOJ
+1 QUIT
+2 ;
PACKAGE ; Checks packages that affects patient merge
+1 ;
+2 IF '$DATA(^VA(15,XDRMPDA,11,XDRMPACK))
DO ADD
IF 1
+3 IF '$TEST
IF $PIECE(^VA(15,XDRMPDA,11,XDRMPACK,0),U,2)=2
DO CHECK
IF XDRMPACK("STATUS")'=2
DO EDIT
+4 QUIT
ADD ;
+1 SET DIE=15
SET DA=XDRMPDA
SET DR="1101///`"_XDRMPACK
+2 SET DR(2,15.01101)=".02////"
+3 DO ^DIE
KILL DIE,DR,DA
+4 DO CHECK
+5 SET DA(1)=XDRMPDA
SET DA=XDRMPACK
+6 SET DIE="^VA(15,"_DA(1)_",11,"
+7 SET DR=".02////"_XDRMPACK("STATUS")
+8 DO ^DIE
KILL DIE,DR,DA
+9 QUIT
CHECK ;
+1 SET XDRZ=0
+2 IF $DATA(^DIC(9.4,XDRMPACK,20,XDRFL,1))
XECUTE ^DIC(9.4,XDRMPACK,20,XDRFL,1)
+3 SET XDRMPACK("STATUS")=$SELECT('XDRZ:2,1:0)
+4 IF XDRZ
IF $DATA(^DIC(9.4,XDRMPACK,20,XDRFL,0))
IF $PIECE(^(0),U,3)]""
SET XDRMPACK("STATUS")=1
+5 KILL XDRZ
+6 QUIT
EDIT ;
+1 SET DA(1)=XDRMPDA
SET DA=XDRMPACK
+2 SET DIE="^VA(15,"_DA(1)_",11,"
+3 SET DR=".02////"_XDRMPACK("STATUS")
+4 DO ^DIE
KILL DIE,DR,DA
+5 QUIT
+6 ;
STATUS ; Changes merge status field to ready if no packages affect merge
+1 SET DIE="^VA(15,"
SET DA=XDRMPDA
SET DR=".05///1"
+2 DO ^DIE
KILL DIE,DR,DA
+3 QUIT
EOJ ; End of job and cleanup
+1 KILL XDRMPACK,XDRMI
+2 QUIT
