XDRMPACK.m

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 ---XDRMPACK   1741     printed  Feb 19, 2025@00:06:02                                                                                                                                                                                                    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