IVMLDEMC ;ALB/BRM/PJR - IVM UPLOAD DEMO CLEAN-UP ; 10/21/04 11:36am
;;2.0;INCOME VERIFICATION MATCH;**79,102**; 21-OCT-94
;
Q
EN(ADDRDT) ; entry point
N IVMDA,IVMDA1,IVMDA2,SEG
N X1,X2,Y,SSN,DFN
D FNDSEG(.SEG)
S IVMDA2=0
F S IVMDA2=$O(^IVM(301.5,IVMDA2)) Q:IVMDA2="" D
.S DFN=$P($G(^IVM(301.5,IVMDA2,0)),"^"),IVMDA1=0
.Q:('DFN)!('$D(^DPT(+DFN)))!('$D(^IVM(301.5,IVMDA2,"IN")))
.F S IVMDA1=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1)) Q:'IVMDA1 D
..D LOOP(DFN,IVMDA2,IVMDA1,.SEG,.ADDRDT)
..; if no display or uploadable fields, delete PID segment
..I ('$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0))&('$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1)) D DELETE^IVMLDEM5(IVMDA2,IVMDA1," ")
Q
LOOP(DFN,IVMDA2,IVMDA1,SEG,ADDRDT) ;
N SEGNUM,X,X1,X2,%Y
Q:'$D(SEG)
S (SEGNUM,SEGNAM)=""
F S SEGNAM=$O(SEG(SEGNAM)) Q:SEGNAM']"" D
.S SEGNUM=$P($G(SEG(SEGNAM)),"^"),IVMTYPE=+$P($G(SEG(SEGNAM)),"^",2)
.S IVMDA=""
.F S IVMDA=$O(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",SEGNUM,IVMDA)) Q:'IVMDA D
..S IVMDAT=$P($G(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0)),"^",3)
..; ignore recent uploads if this is the one-time clean-up
..I (IVMDAT&'$G(ADDRDT(IVMTYPE)))!($G(ADDRDT(IVMTYPE))&'IVMDAT) Q
..; quit if # of days has not passed yet (doesn't apply to EN tag)
..I $G(ADDRDT(IVMTYPE)),IVMDAT S X1=$$DT^XLFDT,X2=IVMDAT D ^%DTC Q:X<ADDRDT(IVMTYPE)
..;process fields that are selectively deleted
..Q:'$$RULES(DFN,SEGNAM)
..I IVMTYPE,$G(ADDRDT(IVMTYPE)) D AUTOLOAD^IVMLDEM9(DFN,IVMDA2,IVMDA1)
..; remove entry from (#301.511) sub-file
..D DELETE^IVMLDEM5(IVMDA2,IVMDA1," "),DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMDA)
Q
RULES(DFN,SEGNAM) ;can this data element be deleted?
Q:SEGNAM'="ZPD09" 1
Q:'$G(DFN) 0
N VADM
D DEM^VADPT
Q:$G(VADM(6))]"" 1 ;delete dod if present in Patient file (#2)
Q 0
;
FNDSEG(SEG) ;
N SEGLOC,LINE,QUIT,TAG,SEGDAT,PIECE
S LINE=1,SEGDAT="",QUIT=0
F S LINE=LINE+1 Q:$G(QUIT) D
.S TAG="DATA+"_LINE,SEGDAT=$P($T(@(TAG)),";;",2)
.I SEGDAT']"" S QUIT=1 Q
.F PIECE=1:1:10 Q:$P(SEGDAT,"~",PIECE)="" D
..S SEGLOC=$P(SEGDAT,"~",PIECE) Q:'$D(^IVM(301.92,"C",SEGLOC))
..S SEG(SEGLOC)=$O(^IVM(301.92,"C",SEGLOC,""))
..Q:'$G(SEG(SEGLOC))
..S $P(SEG(SEGLOC),"^",2)=$P($G(^IVM(301.92,SEG(SEGLOC),0)),"^",8)
Q
;
DATA ;; do not modify below values! They are used to set-up the array
;; that determines the fields to delete and/or process
;;PID111~PID112~PID113~PID114~PID115~PID12~PID13~RF171~ZPD09~ZPD13
;;ZGD03~ZGD04~ZGD05~ZGD061~ZGD062~ZGD063~ZGD064~ZGD065~ZGD07~ZGD08
;;ZPD08~ZPD12~ZPD13~ZEL02~ZEL06~ZPD31~ZPD32
;;
;; end of data (do not remove or modify above "blank" line)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVMLDEMC 2655 printed Dec 13, 2024@02:01:52 Page 2
IVMLDEMC ;ALB/BRM/PJR - IVM UPLOAD DEMO CLEAN-UP ; 10/21/04 11:36am
+1 ;;2.0;INCOME VERIFICATION MATCH;**79,102**; 21-OCT-94
+2 ;
+3 QUIT
EN(ADDRDT) ; entry point
+1 NEW IVMDA,IVMDA1,IVMDA2,SEG
+2 NEW X1,X2,Y,SSN,DFN
+3 DO FNDSEG(.SEG)
+4 SET IVMDA2=0
+5 FOR
SET IVMDA2=$ORDER(^IVM(301.5,IVMDA2))
if IVMDA2=""
QUIT
Begin DoDot:1
+6 SET DFN=$PIECE($GET(^IVM(301.5,IVMDA2,0)),"^")
SET IVMDA1=0
+7 if ('DFN)!('$DATA(^DPT(+DFN)))!('$DATA(^IVM(301.5,IVMDA2,"IN")))
QUIT
+8 FOR
SET IVMDA1=$ORDER(^IVM(301.5,IVMDA2,"IN",IVMDA1))
if 'IVMDA1
QUIT
Begin DoDot:2
+9 DO LOOP(DFN,IVMDA2,IVMDA1,.SEG,.ADDRDT)
+10 ; if no display or uploadable fields, delete PID segment
+11 IF ('$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,0))&('$$DEMO^IVMLDEM5(IVMDA2,IVMDA1,1))
DO DELETE^IVMLDEM5(IVMDA2,IVMDA1," ")
End DoDot:2
End DoDot:1
+12 QUIT
LOOP(DFN,IVMDA2,IVMDA1,SEG,ADDRDT) ;
+1 NEW SEGNUM,X,X1,X2,%Y
+2 if '$DATA(SEG)
QUIT
+3 SET (SEGNUM,SEGNAM)=""
+4 FOR
SET SEGNAM=$ORDER(SEG(SEGNAM))
if SEGNAM']""
QUIT
Begin DoDot:1
+5 SET SEGNUM=$PIECE($GET(SEG(SEGNAM)),"^")
SET IVMTYPE=+$PIECE($GET(SEG(SEGNAM)),"^",2)
+6 SET IVMDA=""
+7 FOR
SET IVMDA=$ORDER(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM","B",SEGNUM,IVMDA))
if 'IVMDA
QUIT
Begin DoDot:2
+8 SET IVMDAT=$PIECE($GET(^IVM(301.5,IVMDA2,"IN",IVMDA1,"DEM",IVMDA,0)),"^",3)
+9 ; ignore recent uploads if this is the one-time clean-up
+10 IF (IVMDAT&'$GET(ADDRDT(IVMTYPE)))!($GET(ADDRDT(IVMTYPE))&'IVMDAT)
QUIT
+11 ; quit if # of days has not passed yet (doesn't apply to EN tag)
+12 IF $GET(ADDRDT(IVMTYPE))
IF IVMDAT
SET X1=$$DT^XLFDT
SET X2=IVMDAT
DO ^%DTC
if X<ADDRDT(IVMTYPE)
QUIT
+13 ;process fields that are selectively deleted
+14 if '$$RULES(DFN,SEGNAM)
QUIT
+15 IF IVMTYPE
IF $GET(ADDRDT(IVMTYPE))
DO AUTOLOAD^IVMLDEM9(DFN,IVMDA2,IVMDA1)
+16 ; remove entry from (#301.511) sub-file
+17 DO DELETE^IVMLDEM5(IVMDA2,IVMDA1," ")
DO DELENT^IVMLDEMU(IVMDA2,IVMDA1,IVMDA)
End DoDot:2
End DoDot:1
+18 QUIT
RULES(DFN,SEGNAM) ;can this data element be deleted?
+1 if SEGNAM'="ZPD09"
QUIT 1
+2 if '$GET(DFN)
QUIT 0
+3 NEW VADM
+4 DO DEM^VADPT
+5 ;delete dod if present in Patient file (#2)
if $GET(VADM(6))]""
QUIT 1
+6 QUIT 0
+7 ;
FNDSEG(SEG) ;
+1 NEW SEGLOC,LINE,QUIT,TAG,SEGDAT,PIECE
+2 SET LINE=1
SET SEGDAT=""
SET QUIT=0
+3 FOR
SET LINE=LINE+1
if $GET(QUIT)
QUIT
Begin DoDot:1
+4 SET TAG="DATA+"_LINE
SET SEGDAT=$PIECE($TEXT(@(TAG)),";;",2)
+5 IF SEGDAT']""
SET QUIT=1
QUIT
+6 FOR PIECE=1:1:10
if $PIECE(SEGDAT,"~",PIECE)=""
QUIT
Begin DoDot:2
+7 SET SEGLOC=$PIECE(SEGDAT,"~",PIECE)
if '$DATA(^IVM(301.92,"C",SEGLOC))
QUIT
+8 SET SEG(SEGLOC)=$ORDER(^IVM(301.92,"C",SEGLOC,""))
+9 if '$GET(SEG(SEGLOC))
QUIT
+10 SET $PIECE(SEG(SEGLOC),"^",2)=$PIECE($GET(^IVM(301.92,SEG(SEGLOC),0)),"^",8)
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
DATA ;; do not modify below values! They are used to set-up the array
+1 ;; that determines the fields to delete and/or process
+2 ;;PID111~PID112~PID113~PID114~PID115~PID12~PID13~RF171~ZPD09~ZPD13
+3 ;;ZGD03~ZGD04~ZGD05~ZGD061~ZGD062~ZGD063~ZGD064~ZGD065~ZGD07~ZGD08
+4 ;;ZPD08~ZPD12~ZPD13~ZEL02~ZEL06~ZPD31~ZPD32
+5 ;;
+6 ;; end of data (do not remove or modify above "blank" line)
