XUMF04P ;BP/RAM - INSTITUTION CLEANUP ;06/28/00
;;8.0;KERNEL;**549**;Jul 10, 1995;Build 9
;
;
Q
;
MAIN ; -- post init entry point
;
Q:$$KSP^XUPARAM("INST")=12000
Q:$P($$PARAM^HLCS2,U,3)="T"
;
M ^TMP("XUMF 04",$$NOW^XLFDT,$J,4)=^DIC(4)
;
S XUMF=1
;
D P101,PHARM,LP1,LP2,NPI,TAX,EN^XUMF04Q,BK
;
Q
;
KT ; -- kill temp node / file backup
;
K ^TMP("XUMF 04")
;
Q
;
BK ; -- background job to kill temp node in 30 days
;
N ZTRTN,ZTDESC,ZTDTH
;
S ZTRTN="KT^XUMF04P"
S ZTDESC="XUMF kill temp backup of file 4 - patch xu549"
S ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,30,0,0,0)
S ZTIO=""
;
D ^%ZTLOAD
;
Q
;
P101 ; -- add subscriber protocols to event protocols
;
N IEN,FDA,IENS
;
; mfp
K FDA
S IEN=$$FIND1^DIC(101,,"B","XUMF 04 MFQ")
S IENS=IEN_","
S FDA(101.0775,"?+1,"_IENS,.01)="XUMF 04 MFR"
D UPDATE^DIE("E","FDA","IENS")
;
; mfq
K FDA
S IEN=$$FIND1^DIC(101,,"B","XUMF 04 MFN")
S IENS=IEN_","
S FDA(101.0775,"?+1,"_IENS,.01)="XUMF 04 MFK"
D UPDATE^DIE("E","FDA","IENS")
;
Q
;
LP1 ; -- loop file
;
W !!!,"CHECKING IDENTIFIER MULTIPLE",!!!
;
N IEN,STA,IEN,DA
;
S STA="" F S STA=$O(^DIC(4,"XUMFIDX","VASTANUM",STA)) Q:STA="" D
. S IEN=$O(^DIC(4,"XUMFIDX","VASTANUM",STA,0)) Q:'IEN
. S DA=$O(^DIC(4,"XUMFIDX","VASTANUM",STA,IEN,0)) Q:'DA
. D CLN
;
Q
;
LP2 ; -- loop file
;
N IEN,NPI,IEN,DA
;
S NPI="" F S NPI=$O(^DIC(4,"XUMFIDX","NPI",NPI)) Q:NPI="" D
. S IEN=$O(^DIC(4,"XUMFIDX","NPI",NPI,0)) Q:'IEN
. S DA=$O(^DIC(4,"XUMFIDX","NPI",NPI,IEN,0)) Q:'DA
. D CLN
;
Q
;
CLN ; -- clean up id mult
;
N IENS,ROOT,DIK,DIC
;
S IENS=IEN_","
;
S ROOT=$$ROOT^DILFD(4.9999,","_IENS,1)
S DA(1)=+IENS,DIK=$P(ROOT,")")_"," D ^DIK
;
Q
;
NPI ; -- clean npi
;
N IEN,NPI,IEN,ROOT,IENS
;
S IEN=0 F S IEN=$O(^DIC(4,IEN)) Q:'IEN D
. S NPI=$G(^DIC(4,IEN,"NPI")) Q:'NPI
. S IDX=0 F S IDX=$O(^DIC(4,IEN,"NPISTATUS",IDX)) Q:'IDX D
.. Q:$P(^DIC(4,IEN,"NPISTATUS",IDX,0),U,3)=NPI
.. S IENS=IEN_",",ROOT=$$ROOT^DILFD(4.042,","_IENS,1)
.. N DA,DIK,DIC S DA(1)=+IENS,DA=IDX,DIK=$P(ROOT,")")_"," D ^DIK
;
Q
;
PHARM ; REMOVE DUPLICATE PHARM
;
W !!!,"CLEANING UP DUPLICATE PHARMACY ENTRIES",!!!
;
N NAME,IEN,IENS,FDA,XUMF
;
S NAME=""
F S NAME=$O(^DIC(4,"B",NAME)) Q:NAME="" Q:$E(NAME,1,2)="ZZ" D
.Q:NAME'[" PHARM"
.S IEN=0 F S IEN=$O(^DIC(4,"B",NAME,IEN)) Q:'IEN D
..Q:+$G(^DIC(4,IEN,"NPI"))
..Q:+$G(^DIC(4,IEN,99))
..Q:$P($G(^DIC(4,IEN,0)),U,11)="L"
..S XUMF=1
..S IENS=IEN_","
..K FDA
..S FDA(4,IENS,.01)=$E("ZZ DUP "_NAME,1,30)
..S FDA(4,IENS,101)="INACTIVE"
..D FILE^DIE("E","FDA")
;
Q
;
TAX ;
;
S IEN=0 F S IEN=$O(^DIC(4,IEN)) Q:'IEN D
.Q:'$D(^DIC(4,IEN,"TAXONOMY"))
.N ROOT,IDX,IENS
.S IENS=IEN_",",ROOT=$$ROOT^DILFD(4.043,","_IENS,1)
.S IDX=$O(@ROOT@(0)) Q:'IDX
.F S IDX=$O(@ROOT@(IDX)) Q:'IDX D
..D
...N DA,DIK,DIC S DA(1)=+IENS,DA=IDX,DIK=$P(ROOT,")")_"," D ^DIK
;
Q
;
EXIT ; -- cleanup, and quit
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMF04P 3053 printed Apr 09, 2024@21:07:45 Page 2
XUMF04P ;BP/RAM - INSTITUTION CLEANUP ;06/28/00
+1 ;;8.0;KERNEL;**549**;Jul 10, 1995;Build 9
+2 ;
+3 ;
+4 QUIT
+5 ;
MAIN ; -- post init entry point
+1 ;
+2 if $$KSP^XUPARAM("INST")=12000
QUIT
+3 if $PIECE($$PARAM^HLCS2,U,3)="T"
QUIT
+4 ;
+5 MERGE ^TMP("XUMF 04",$$NOW^XLFDT,$JOB,4)=^DIC(4)
+6 ;
+7 SET XUMF=1
+8 ;
+9 DO P101
DO PHARM
DO LP1
DO LP2
DO NPI
DO TAX
DO EN^XUMF04Q
DO BK
+10 ;
+11 QUIT
+12 ;
KT ; -- kill temp node / file backup
+1 ;
+2 KILL ^TMP("XUMF 04")
+3 ;
+4 QUIT
+5 ;
BK ; -- background job to kill temp node in 30 days
+1 ;
+2 NEW ZTRTN,ZTDESC,ZTDTH
+3 ;
+4 SET ZTRTN="KT^XUMF04P"
+5 SET ZTDESC="XUMF kill temp backup of file 4 - patch xu549"
+6 SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,30,0,0,0)
+7 SET ZTIO=""
+8 ;
+9 DO ^%ZTLOAD
+10 ;
+11 QUIT
+12 ;
P101 ; -- add subscriber protocols to event protocols
+1 ;
+2 NEW IEN,FDA,IENS
+3 ;
+4 ; mfp
+5 KILL FDA
+6 SET IEN=$$FIND1^DIC(101,,"B","XUMF 04 MFQ")
+7 SET IENS=IEN_","
+8 SET FDA(101.0775,"?+1,"_IENS,.01)="XUMF 04 MFR"
+9 DO UPDATE^DIE("E","FDA","IENS")
+10 ;
+11 ; mfq
+12 KILL FDA
+13 SET IEN=$$FIND1^DIC(101,,"B","XUMF 04 MFN")
+14 SET IENS=IEN_","
+15 SET FDA(101.0775,"?+1,"_IENS,.01)="XUMF 04 MFK"
+16 DO UPDATE^DIE("E","FDA","IENS")
+17 ;
+18 QUIT
+19 ;
LP1 ; -- loop file
+1 ;
+2 WRITE !!!,"CHECKING IDENTIFIER MULTIPLE",!!!
+3 ;
+4 NEW IEN,STA,IEN,DA
+5 ;
+6 SET STA=""
FOR
SET STA=$ORDER(^DIC(4,"XUMFIDX","VASTANUM",STA))
if STA=""
QUIT
Begin DoDot:1
+7 SET IEN=$ORDER(^DIC(4,"XUMFIDX","VASTANUM",STA,0))
if 'IEN
QUIT
+8 SET DA=$ORDER(^DIC(4,"XUMFIDX","VASTANUM",STA,IEN,0))
if 'DA
QUIT
+9 DO CLN
End DoDot:1
+10 ;
+11 QUIT
+12 ;
LP2 ; -- loop file
+1 ;
+2 NEW IEN,NPI,IEN,DA
+3 ;
+4 SET NPI=""
FOR
SET NPI=$ORDER(^DIC(4,"XUMFIDX","NPI",NPI))
if NPI=""
QUIT
Begin DoDot:1
+5 SET IEN=$ORDER(^DIC(4,"XUMFIDX","NPI",NPI,0))
if 'IEN
QUIT
+6 SET DA=$ORDER(^DIC(4,"XUMFIDX","NPI",NPI,IEN,0))
if 'DA
QUIT
+7 DO CLN
End DoDot:1
+8 ;
+9 QUIT
+10 ;
CLN ; -- clean up id mult
+1 ;
+2 NEW IENS,ROOT,DIK,DIC
+3 ;
+4 SET IENS=IEN_","
+5 ;
+6 SET ROOT=$$ROOT^DILFD(4.9999,","_IENS,1)
+7 SET DA(1)=+IENS
SET DIK=$PIECE(ROOT,")")_","
DO ^DIK
+8 ;
+9 QUIT
+10 ;
NPI ; -- clean npi
+1 ;
+2 NEW IEN,NPI,IEN,ROOT,IENS
+3 ;
+4 SET IEN=0
FOR
SET IEN=$ORDER(^DIC(4,IEN))
if 'IEN
QUIT
Begin DoDot:1
+5 SET NPI=$GET(^DIC(4,IEN,"NPI"))
if 'NPI
QUIT
+6 SET IDX=0
FOR
SET IDX=$ORDER(^DIC(4,IEN,"NPISTATUS",IDX))
if 'IDX
QUIT
Begin DoDot:2
+7 if $PIECE(^DIC(4,IEN,"NPISTATUS",IDX,0),U,3)=NPI
QUIT
+8 SET IENS=IEN_","
SET ROOT=$$ROOT^DILFD(4.042,","_IENS,1)
+9 NEW DA,DIK,DIC
SET DA(1)=+IENS
SET DA=IDX
SET DIK=$PIECE(ROOT,")")_","
DO ^DIK
End DoDot:2
End DoDot:1
+10 ;
+11 QUIT
+12 ;
PHARM ; REMOVE DUPLICATE PHARM
+1 ;
+2 WRITE !!!,"CLEANING UP DUPLICATE PHARMACY ENTRIES",!!!
+3 ;
+4 NEW NAME,IEN,IENS,FDA,XUMF
+5 ;
+6 SET NAME=""
+7 FOR
SET NAME=$ORDER(^DIC(4,"B",NAME))
if NAME=""
QUIT
if $EXTRACT(NAME,1,2)="ZZ"
QUIT
Begin DoDot:1
+8 if NAME'[" PHARM"
QUIT
+9 SET IEN=0
FOR
SET IEN=$ORDER(^DIC(4,"B",NAME,IEN))
if 'IEN
QUIT
Begin DoDot:2
+10 if +$GET(^DIC(4,IEN,"NPI"))
QUIT
+11 if +$GET(^DIC(4,IEN,99))
QUIT
+12 if $PIECE($GET(^DIC(4,IEN,0)),U,11)="L"
QUIT
+13 SET XUMF=1
+14 SET IENS=IEN_","
+15 KILL FDA
+16 SET FDA(4,IENS,.01)=$EXTRACT("ZZ DUP "_NAME,1,30)
+17 SET FDA(4,IENS,101)="INACTIVE"
+18 DO FILE^DIE("E","FDA")
End DoDot:2
End DoDot:1
+19 ;
+20 QUIT
+21 ;
TAX ;
+1 ;
+2 SET IEN=0
FOR
SET IEN=$ORDER(^DIC(4,IEN))
if 'IEN
QUIT
Begin DoDot:1
+3 if '$DATA(^DIC(4,IEN,"TAXONOMY"))
QUIT
+4 NEW ROOT,IDX,IENS
+5 SET IENS=IEN_","
SET ROOT=$$ROOT^DILFD(4.043,","_IENS,1)
+6 SET IDX=$ORDER(@ROOT@(0))
if 'IDX
QUIT
+7 FOR
SET IDX=$ORDER(@ROOT@(IDX))
if 'IDX
QUIT
Begin DoDot:2
+8 Begin DoDot:3
+9 NEW DA,DIK,DIC
SET DA(1)=+IENS
SET DA=IDX
SET DIK=$PIECE(ROOT,")")_","
DO ^DIK
End DoDot:3
End DoDot:2
End DoDot:1
+10 ;
+11 QUIT
+12 ;
EXIT ; -- cleanup, and quit
+1 ;
+2 QUIT
+3 ;
