IVM273A.m

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 ---IVM273A   3198     printed  Apr 23, 2025@18:14:38                                                                                                                                                                                                     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