IVM273A ;ALB/PDJ IVM*2.0*73 - CLEANUP IVM PATIENT FILE;02/07/2003
;;2.0;INCOME VERIFICATION MATCH;**73**; 21-OCT-94
;
EN N DFN,I,R3015,SEG,TEXT,TYPE,X,X1,X2,%,XTPAT,IVMPH,IVMAD
;
D BMES^XPDUTL(" ")
D BMES^XPDUTL(" The Post Install will now process through the IVM PATIENT")
D BMES^XPDUTL(" FILE to remove entries which do not contain any uploadable")
D BMES^XPDUTL(" or non-uploadable fields.")
D BMES^XPDUTL(" ")
;
I $D(XPDNM) D
. I $$VERCP^XPDUTL("R3015")'>0 D
. . S %=$$NEWCP^XPDUTL("R3015","","0")
;
F I="PATREC" D
. I $D(^XTMP("IVM*2.0*73-"_I)) Q
. S X1=DT
. S X2=30
. D C^%DTC
. S TEXT=X_"^"_$$DT^XLFDT_"^IVM*2.0*73 POST-INSTALL "
. S TEXT=TEXT_$S(I="PATREC":"IVM Patient Records",1:"filing errors")
. S ^XTMP("IVM*2.0*73-"_I,0)=TEXT
;
S XTPAT="IVM*2.0*73-PATREC"
;
I '$D(XPDNM) D
. S ^XTMP(XTPAT,1)=0
I $D(XPDNM)&'$D(^XTMP(XTPAT,1)) S ^XTMP(XTPAT,1)=0
I $D(XPDNM) S %=$$VERCP^XPDUTL("R3015")
I $G(%)="" S %=0
I %=0 D EN1
Q
;
EN1 I '$D(XPDNM) S R3015=0
I $D(XPDNM) S R3015=$$PARCP^XPDUTL("R3015")
F S R3015=$O(^IVM(301.5,R3015)) Q:'R3015 D
. S SEG="B"
. F S SEG=$O(^IVM(301.5,R3015,"IN",SEG),-1) Q:'SEG D
. . S (IVMAD,IVMPH)=0
. . S DFN=+$P($G(^IVM(301.5,R3015,0)),U,1) Q:'DFN
. . S TYPE=$P($G(^IVM(301.5,R3015,"IN",SEG,0)),U,2) Q:TYPE'="PID"
. . D CHKREC
. . S TYPE=$P($G(^IVM(301.5,R3015,"IN",SEG,0)),U,2)
. . I TYPE="" D PROCREC
. I $D(XPDNM) S %=$$UPCP^XPDUTL("R3015",R3015)
;
D MAIL^IVM273M
I $D(XPDNM) S %=$$COMCP^XPDUTL("R3015")
D BMES^XPDUTL(" Cleanup of IVM PATIENT file is complete.")
Q
;
CHKREC ; Check Demographic fields
N DEMO,DATA0,FLDLOC,IVMDATA,PATPH,PH
S DEMO=0
F S DEMO=$O(^IVM(301.5,R3015,"IN",SEG,"DEM",DEMO)) Q:'DEMO D
. S DATA0=$G(^IVM(301.5,R3015,"IN",SEG,"DEM",DEMO,0)) Q:DATA0=""
. S FLDLOC=$P(DATA0,"^",1),IVMDATA=$P(DATA0,"^",2)
. I IVMDATA="" D Q
. . ; only process address fields
. . I '$D(^IVM(301.92,"AD",FLDLOC)) Q
. . S IVMAD=1 D DELFLD
. I FLDLOC=11 D
. . S PATPH=$$CONVPH^IVMPREC8($P($G(^DPT(DFN,.13)),"^",1))
. . S PH=$$CONVPH^IVMPREC8(IVMDATA)
. . ; quit if the phone numbers are the same, otherwise delete
. . ; the field from the IVM PATIENT file
. . I PATPH'=PH Q
. . S IVMPH=1 D DELFLD
; If no uploadable and no non-uploadable fields delete then entry
I '$$DEMO^IVMLDEM5(R3015,SEG,0),'$$DEMO^IVMLDEM5(R3015,SEG,1) D
. D DELETE^IVMLDEM5(R3015,SEG,"NAME,DUMMY")
Q
;
DELFLD ; Delete null field
N DA,DIE,DR
S DA=DEMO,DA(1)=SEG,DA(2)=R3015
S DIE="^IVM(301.5,"_DA(2)_",""IN"","_DA(1)_",""DEM"","
S DR=".01////@" D ^DIE
Q
;
PROCREC ; Save processed records to the XTMP file
N DATA,NAME,SSN
S DATA=$G(^DPT(DFN,0)) Q:DATA=""
S NAME=$P(DATA,"^",1)
S SSN=$P(DATA,"^",9)
;
; Only count the record once even if more than one entry was
; updated.
;
I '$D(^XTMP(XTPAT,"RECS",DFN)) S ^XTMP(XTPAT,1)=$G(^XTMP(XTPAT,1))+1
S ^XTMP(XTPAT,"RECS",DFN)=R3015_U_NAME_U_SSN
I IVMAD S $P(^XTMP(XTPAT,"RECS",DFN),U,4)=1
I IVMPH S $P(^XTMP(XTPAT,"RECS",DFN),U,5)=1
Q
;
CLEANUP ; Used to cleanup XTMP global for testing only
S XTPAT="IVM*2.0*73-PATREC"
;
K ^XTMP(XTPAT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIVM273A 3198 printed Sep 23, 2025@19:36:19 Page 2
IVM273A ;ALB/PDJ IVM*2.0*73 - CLEANUP IVM PATIENT FILE;02/07/2003
+1 ;;2.0;INCOME VERIFICATION MATCH;**73**; 21-OCT-94
+2 ;
EN NEW DFN,I,R3015,SEG,TEXT,TYPE,X,X1,X2,%,XTPAT,IVMPH,IVMAD
+1 ;
+2 DO BMES^XPDUTL(" ")
+3 DO BMES^XPDUTL(" The Post Install will now process through the IVM PATIENT")
+4 DO BMES^XPDUTL(" FILE to remove entries which do not contain any uploadable")
+5 DO BMES^XPDUTL(" or non-uploadable fields.")
+6 DO BMES^XPDUTL(" ")
+7 ;
+8 IF $DATA(XPDNM)
Begin DoDot:1
+9 IF $$VERCP^XPDUTL("R3015")'>0
Begin DoDot:2
+10 SET %=$$NEWCP^XPDUTL("R3015","","0")
End DoDot:2
End DoDot:1
+11 ;
+12 FOR I="PATREC"
Begin DoDot:1
+13 IF $DATA(^XTMP("IVM*2.0*73-"_I))
QUIT
+14 SET X1=DT
+15 SET X2=30
+16 DO C^%DTC
+17 SET TEXT=X_"^"_$$DT^XLFDT_"^IVM*2.0*73 POST-INSTALL "
+18 SET TEXT=TEXT_$SELECT(I="PATREC":"IVM Patient Records",1:"filing errors")
+19 SET ^XTMP("IVM*2.0*73-"_I,0)=TEXT
End DoDot:1
+20 ;
+21 SET XTPAT="IVM*2.0*73-PATREC"
+22 ;
+23 IF '$DATA(XPDNM)
Begin DoDot:1
+24 SET ^XTMP(XTPAT,1)=0
End DoDot:1
+25 IF $DATA(XPDNM)&'$DATA(^XTMP(XTPAT,1))
SET ^XTMP(XTPAT,1)=0
+26 IF $DATA(XPDNM)
SET %=$$VERCP^XPDUTL("R3015")
+27 IF $GET(%)=""
SET %=0
+28 IF %=0
DO EN1
+29 QUIT
+30 ;
EN1 IF '$DATA(XPDNM)
SET R3015=0
+1 IF $DATA(XPDNM)
SET R3015=$$PARCP^XPDUTL("R3015")
+2 FOR
SET R3015=$ORDER(^IVM(301.5,R3015))
if 'R3015
QUIT
Begin DoDot:1
+3 SET SEG="B"
+4 FOR
SET SEG=$ORDER(^IVM(301.5,R3015,"IN",SEG),-1)
if 'SEG
QUIT
Begin DoDot:2
+5 SET (IVMAD,IVMPH)=0
+6 SET DFN=+$PIECE($GET(^IVM(301.5,R3015,0)),U,1)
if 'DFN
QUIT
+7 SET TYPE=$PIECE($GET(^IVM(301.5,R3015,"IN",SEG,0)),U,2)
if TYPE'="PID"
QUIT
+8 DO CHKREC
+9 SET TYPE=$PIECE($GET(^IVM(301.5,R3015,"IN",SEG,0)),U,2)
+10 IF TYPE=""
DO PROCREC
End DoDot:2
+11 IF $DATA(XPDNM)
SET %=$$UPCP^XPDUTL("R3015",R3015)
End DoDot:1
+12 ;
+13 DO MAIL^IVM273M
+14 IF $DATA(XPDNM)
SET %=$$COMCP^XPDUTL("R3015")
+15 DO BMES^XPDUTL(" Cleanup of IVM PATIENT file is complete.")
+16 QUIT
+17 ;
CHKREC ; Check Demographic fields
+1 NEW DEMO,DATA0,FLDLOC,IVMDATA,PATPH,PH
+2 SET DEMO=0
+3 FOR
SET DEMO=$ORDER(^IVM(301.5,R3015,"IN",SEG,"DEM",DEMO))
if 'DEMO
QUIT
Begin DoDot:1
+4 SET DATA0=$GET(^IVM(301.5,R3015,"IN",SEG,"DEM",DEMO,0))
if DATA0=""
QUIT
+5 SET FLDLOC=$PIECE(DATA0,"^",1)
SET IVMDATA=$PIECE(DATA0,"^",2)
+6 IF IVMDATA=""
Begin DoDot:2
+7 ; only process address fields
+8 IF '$DATA(^IVM(301.92,"AD",FLDLOC))
QUIT
+9 SET IVMAD=1
DO DELFLD
End DoDot:2
QUIT
+10 IF FLDLOC=11
Begin DoDot:2
+11 SET PATPH=$$CONVPH^IVMPREC8($PIECE($GET(^DPT(DFN,.13)),"^",1))
+12 SET PH=$$CONVPH^IVMPREC8(IVMDATA)
+13 ; quit if the phone numbers are the same, otherwise delete
+14 ; the field from the IVM PATIENT file
+15 IF PATPH'=PH
QUIT
+16 SET IVMPH=1
DO DELFLD
End DoDot:2
End DoDot:1
+17 ; If no uploadable and no non-uploadable fields delete then entry
+18 IF '$$DEMO^IVMLDEM5(R3015,SEG,0)
IF '$$DEMO^IVMLDEM5(R3015,SEG,1)
Begin DoDot:1
+19 DO DELETE^IVMLDEM5(R3015,SEG,"NAME,DUMMY")
End DoDot:1
+20 QUIT
+21 ;
DELFLD ; Delete null field
+1 NEW DA,DIE,DR
+2 SET DA=DEMO
SET DA(1)=SEG
SET DA(2)=R3015
+3 SET DIE="^IVM(301.5,"_DA(2)_",""IN"","_DA(1)_",""DEM"","
+4 SET DR=".01////@"
DO ^DIE
+5 QUIT
+6 ;
PROCREC ; Save processed records to the XTMP file
+1 NEW DATA,NAME,SSN
+2 SET DATA=$GET(^DPT(DFN,0))
if DATA=""
QUIT
+3 SET NAME=$PIECE(DATA,"^",1)
+4 SET SSN=$PIECE(DATA,"^",9)
+5 ;
+6 ; Only count the record once even if more than one entry was
+7 ; updated.
+8 ;
+9 IF '$DATA(^XTMP(XTPAT,"RECS",DFN))
SET ^XTMP(XTPAT,1)=$GET(^XTMP(XTPAT,1))+1
+10 SET ^XTMP(XTPAT,"RECS",DFN)=R3015_U_NAME_U_SSN
+11 IF IVMAD
SET $PIECE(^XTMP(XTPAT,"RECS",DFN),U,4)=1
+12 IF IVMPH
SET $PIECE(^XTMP(XTPAT,"RECS",DFN),U,5)=1
+13 QUIT
+14 ;
CLEANUP ; Used to cleanup XTMP global for testing only
+1 SET XTPAT="IVM*2.0*73-PATREC"
+2 ;
+3 KILL ^XTMP(XTPAT)
+4 QUIT
