DG53591B ;ALB/GN - DG*5.3*591 CLEANUP FOR PURGED DEPENDENT INCOME 2ND PASS; 3/17/04 12:26pm ; 7/26/04 10:55am
;;5.3;Registration;**591,1015**;Aug 13, 1993;Build 21
Q
;
; 1. Drive thru the INCOME RELATION file (#408.22) and look for recs
; whose fields of MARRIED LAST CALENDAR YEAR #.05 and
; LIVED WITH PATIENT #.06 are flagged "Y".
; 2. Use the patient DFN to find the corresponding records in the
; PATIENT RELATION file (#408.12).
; 3. Drive thru the Effective Date records multiple (#408.1275), in
; reverse order and look for the first spouse rec that is flagged
; as inactive and points to a MT that does not exist.
; 4. If found, delete this record. Keep deleting record until a rec
; is found that points to valid MT.
;
EN ; Entry to 2nd pass cleanup of dependent recs
N DGMT,DGDFN,R21,DG22,LIV,MLY
;
;drive thru 408.22 per each DFN and look at each DFN in reverse order
;to get most recent info on Married last year & living with last year
S DGDFN=0
F S DGDFN=$O(^DGMT(408.22,"B",DGDFN)) Q:'DGDFN D Q:ZTSTOP
. Q:'$D(^DPT(DGDFN,0))
. S DG22=""
. F S DG22=$O(^DGMT(408.22,"B",DGDFN,DG22),-1) Q:'+DG22 D
. . S MLY=$P($G(^DGMT(408.22,DG22,0)),"^",5) ;married last year?
. . S LIV=$P($G(^DGMT(408.22,DG22,0)),"^",6) ;living w/last yr?
. . S R21=$P($G(^DGMT(408.22,DG22,0)),"^",2) ;408.21 ien
. . S DGMT=$P($G(^DGMT(408.22,DG22,"MT")),"^",1) ;MT IEN
. . Q:DGMT="" ;bad MT=null, quit
. . Q:$P($G(^DGMT(408.31,DGMT,0)),"^",23)'=1 ;not VAMC test,quit
. . Q:$E(+$G(^DGMT(408.31,DGMT,0)),1,3)<303 ;skip < 2003
. . Q:('MLY)!('LIV)!(R21="")
. . Q:'$D(^DGMT(408.22,"AMT",DGMT,DGDFN,R21))
. . D D40812(DGDFN,R21)
. ;update last processed info
. S $P(^XTMP(NAMSPC,0,0),U,7)=DGDFN
. ;check for stop request after every 20 processed DFN recs
. I QQ#20=0 D
. . S:$$S^%ZTLOAD ZTSTOP=1
. . I $D(^XTMP(NAMSPC,0,"STOP")) S ZTSTOP=1 K ^XTMP(NAMSPC,0,"STOP")
;
;set status
I ZTSTOP D
. S $P(^XTMP(NAMSPC,0,0),U,5,6)="STOPPED"_U_$$NOW^XLFDT
E D
. S $P(^XTMP(NAMSPC,0,0),U,5,6)="COMPLETED"_U_$$NOW^XLFDT
;
Q
;
D40812(DFN,R21) ;drive through 408.12 ien's and process spouse relation recs
N R12,ENODE,EIEN,DA,TEXT,SSN
Q:R21=""
S R12=$P($G(^DGMT(408.21,R21,0)),"^",2)
Q:R12=""
Q:$P($G(^DGPR(408.12,R12,0)),"^",2)'=2 ;only process spouse
; drive through the Effective Date Multiple in ien reverse order
S EIEN="A"
F S EIEN=$O(^DGPR(408.12,R12,"E",EIEN),-1) Q:'EIEN D Q:ZTSTOP
. S SSN=$E(^DPT(DFN,0),1)_$E($P(^DPT(DFN,0),"^",9),6,9)
. S IVMTOT=IVMTOT+1 ;tot ien's read
. S ENODE=$G(^DGPR(408.12,R12,"E",EIEN,0))
. Q:+$P(ENODE,"^",2) ;active flag, quit
. Q:'+$P(ENODE,"^",4) ;no MT ien, quit
. Q:$D(^DGMT(408.31,$P(ENODE,"^",4),0)) ;ptr to valid MT, quit
. ;
. ; if inactive and does not point to a valid MT, delete this
. ; effective date multiple rec from 408.1275
. S DA=EIEN,DA(1)=R12,DIK="^DGPR(408.12,"_DA(1)_",""E"","
. D:'TESTING ^DIK
. Q:$G(^XTMP(NAMSPC,9999999999.40812,R12,EIEN,"DEL"))=ENODE
. S ^XTMP(NAMSPC,9999999999.40812,R12,EIEN,"DEL")=ENODE
. S IVMDPTR=IVMDPTR+1 ;increment del 408.1275 recs
. ;
. ; add to detail XTMP for mail message
. S TEXT=" SSN:"_SSN_" Del eff date rec "
. S TEXT=TEXT_$$FMTE^XLFDT(+ENODE,2)_" data:"_R12_","_EIEN
. S TEXT=TEXT_"="_ENODE_" <bad MT"
. W:'$D(ZTQUEUED) !,TEXT
. S ^XTMP(NAMSPC,"DET R12",DFN,R12)=TEXT
;
;update last processed info
S $P(^XTMP(NAMSPC,0,0),U,2)=IVMTOT ;last total recs read
S $P(^XTMP(NAMSPC,0,0),U,8)=IVMDPTR ;last del 408.1275 recs
Q
DG53591B ;ALB/GN - DG*5.3*591 CLEANUP FOR PURGED DEPENDENT INCOME 2ND PASS; 3/17/04 12:26pm ; 7/26/04 10:55am
+1 ;;5.3;Registration;**591,1015**;Aug 13, 1993;Build 21
+2 QUIT
+3 ;
+4 ; 1. Drive thru the INCOME RELATION file (#408.22) and look for recs
+5 ; whose fields of MARRIED LAST CALENDAR YEAR #.05 and
+6 ; LIVED WITH PATIENT #.06 are flagged "Y".
+7 ; 2. Use the patient DFN to find the corresponding records in the
+8 ; PATIENT RELATION file (#408.12).
+9 ; 3. Drive thru the Effective Date records multiple (#408.1275), in
+10 ; reverse order and look for the first spouse rec that is flagged
+11 ; as inactive and points to a MT that does not exist.
+12 ; 4. If found, delete this record. Keep deleting record until a rec
+13 ; is found that points to valid MT.
+14 ;
EN ; Entry to 2nd pass cleanup of dependent recs
+1 NEW DGMT,DGDFN,R21,DG22,LIV,MLY
+2 ;
+3 ;drive thru 408.22 per each DFN and look at each DFN in reverse order
+4 ;to get most recent info on Married last year & living with last year
+5 SET DGDFN=0
+6 FOR
SET DGDFN=$ORDER(^DGMT(408.22,"B",DGDFN))
IF 'DGDFN
QUIT
Begin DoDot:1
+7 IF '$DATA(^DPT(DGDFN,0))
QUIT
+8 SET DG22=""
+9 FOR
SET DG22=$ORDER(^DGMT(408.22,"B",DGDFN,DG22),-1)
IF '+DG22
QUIT
Begin DoDot:2
+10 ;married last year?
SET MLY=$PIECE($GET(^DGMT(408.22,DG22,0)),"^",5)
+11 ;living w/last yr?
SET LIV=$PIECE($GET(^DGMT(408.22,DG22,0)),"^",6)
+12 ;408.21 ien
SET R21=$PIECE($GET(^DGMT(408.22,DG22,0)),"^",2)
+13 ;MT IEN
SET DGMT=$PIECE($GET(^DGMT(408.22,DG22,"MT")),"^",1)
+14 ;bad MT=null, quit
IF DGMT=""
QUIT
+15 ;not VAMC test,quit
IF $PIECE($GET(^DGMT(408.31,DGMT,0)),"^",23)'=1
QUIT
+16 ;skip < 2003
IF $EXTRACT(+$GET(^DGMT(408.31,DGMT,0)),1,3)<303
QUIT
+17 IF ('MLY)!('LIV)!(R21="")
QUIT
+18 IF '$DATA(^DGMT(408.22,"AMT",DGMT,DGDFN,R21))
QUIT
+19 DO D40812(DGDFN,R21)
End DoDot:2
+20 ;update last processed info
+21 SET $PIECE(^XTMP(NAMSPC,0,0),U,7)=DGDFN
+22 ;check for stop request after every 20 processed DFN recs
+23 IF QQ#20=0
Begin DoDot:2
+24 IF $$S^%ZTLOAD
SET ZTSTOP=1
+25 IF $DATA(^XTMP(NAMSPC,0,"STOP"))
SET ZTSTOP=1
KILL ^XTMP(NAMSPC,0,"STOP")
End DoDot:2
End DoDot:1
IF ZTSTOP
QUIT
+26 ;
+27 ;set status
+28 IF ZTSTOP
Begin DoDot:1
+29 SET $PIECE(^XTMP(NAMSPC,0,0),U,5,6)="STOPPED"_U_$$NOW^XLFDT
End DoDot:1
+30 IF '$TEST
Begin DoDot:1
+31 SET $PIECE(^XTMP(NAMSPC,0,0),U,5,6)="COMPLETED"_U_$$NOW^XLFDT
End DoDot:1
+32 ;
+33 QUIT
+34 ;
D40812(DFN,R21) ;drive through 408.12 ien's and process spouse relation recs
+1 NEW R12,ENODE,EIEN,DA,TEXT,SSN
+2 IF R21=""
QUIT
+3 SET R12=$PIECE($GET(^DGMT(408.21,R21,0)),"^",2)
+4 IF R12=""
QUIT
+5 ;only process spouse
IF $PIECE($GET(^DGPR(408.12,R12,0)),"^",2)'=2
QUIT
+6 ; drive through the Effective Date Multiple in ien reverse order
+7 SET EIEN="A"
+8 FOR
SET EIEN=$ORDER(^DGPR(408.12,R12,"E",EIEN),-1)
IF 'EIEN
QUIT
Begin DoDot:1
+9 SET SSN=$EXTRACT(^DPT(DFN,0),1)_$EXTRACT($PIECE(^DPT(DFN,0),"^",9),6,9)
+10 ;tot ien's read
SET IVMTOT=IVMTOT+1
+11 SET ENODE=$GET(^DGPR(408.12,R12,"E",EIEN,0))
+12 ;active flag, quit
IF +$PIECE(ENODE,"^",2)
QUIT
+13 ;no MT ien, quit
IF '+$PIECE(ENODE,"^",4)
QUIT
+14 ;ptr to valid MT, quit
IF $DATA(^DGMT(408.31,$PIECE(ENODE,"^",4),0))
QUIT
+15 ;
+16 ; if inactive and does not point to a valid MT, delete this
+17 ; effective date multiple rec from 408.1275
+18 SET DA=EIEN
SET DA(1)=R12
SET DIK="^DGPR(408.12,"_DA(1)_",""E"","
+19 IF 'TESTING
DO ^DIK
+20 IF $GET(^XTMP(NAMSPC,9999999999.40812,R12,EIEN,"DEL"))=ENODE
QUIT
+21 SET ^XTMP(NAMSPC,9999999999.40812,R12,EIEN,"DEL")=ENODE
+22 ;increment del 408.1275 recs
SET IVMDPTR=IVMDPTR+1
+23 ;
+24 ; add to detail XTMP for mail message
+25 SET TEXT=" SSN:"_SSN_" Del eff date rec "
+26 SET TEXT=TEXT_$$FMTE^XLFDT(+ENODE,2)_" data:"_R12_","_EIEN
+27 SET TEXT=TEXT_"="_ENODE_" <bad MT"
+28 IF '$DATA(ZTQUEUED)
WRITE !,TEXT
+29 SET ^XTMP(NAMSPC,"DET R12",DFN,R12)=TEXT
End DoDot:1
IF ZTSTOP
QUIT
+30 ;
+31 ;update last processed info
+32 ;last total recs read
SET $PIECE(^XTMP(NAMSPC,0,0),U,2)=IVMTOT
+33 ;last del 408.1275 recs
SET $PIECE(^XTMP(NAMSPC,0,0),U,8)=IVMDPTR
+34 QUIT
