- 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 Jan 18, 2025@03:02:16 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)