- XUMF04P ;BP/RAM - INSTITUTION CLEANUP ;06/28/00
- ;;8.0;KERNEL;**549**;Jul 10, 1995;Build 12
- ;
- ;
- 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
- ;
- XUMF04P ;BP/RAM - INSTITUTION CLEANUP ;06/28/00
- +1 ;;8.0;KERNEL;**549**;Jul 10, 1995;Build 12
- +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 ;