IBY374PO ;PRXM/CMW - Post install routine for patch 374 ; 10 May 2007 9:41 AM
;;2.0;INTEGRATED BILLING;**374**;21-MAR-94;Build 16
;
; Call at tags only
Q
; This routine will clean up entries in the file with NPIs delete status (2)
;
EN ; Post Install Routine primary entry point
;
D DEL
D CLEAN
Q
;
DEL ; Look for NPI with delete status of "2"
N IBIEN,STA,DA,IBOLDNPI
S IBIEN=0
F S IBIEN=$O(^IBA(355.93,IBIEN)) Q:'IBIEN D
. S DA="A"
. ; Loop through deleted NPIs (Status "2")
. S STA=2
. F S DA=$O(^IBA(355.93,IBIEN,"NPISTATUS","NPISTATUS",STA,DA),-1) Q:'DA D
. . S IBOLDNPI=$P(^IBA(355.93,IBIEN,"NPISTATUS",DA,0),U,3)
. . D COMP
Q
;
COMP ;COMPLETELY DELETE THE NPI
;If NPI has status of "2" remove all entries related to this NPI.
N OIEN
S OIEN="A"
F S OIEN=$O(^IBA(355.93,IBIEN,"NPISTATUS","C",IBOLDNPI,OIEN),-1) Q:'OIEN D
. NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X
. NEW DP,DM,DK,DL,DIEL
. S DA(1)=IBIEN,DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"",",DA=OIEN
. D ^DIK
. ; kill 41.01 references
. K ^IBA(355.93,"NPI",IBOLDNPI,DA),^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA)
Q
;
CLEAN ; Clean up ^IBA(355.93,IEN,"NPISTATUS",0) if there are no multiples in the sub-file.
N IBIEN
S IBIEN=0
F S IBIEN=$O(^IBA(355.93,IBIEN)) Q:'IBIEN D
. Q:$G(^IBA(355.93,IBIEN,"NPISTATUS",0))=""
. I +$P($G(^IBA(355.93,IBIEN,"NPISTATUS",0)),U,4)=0 D
. . K ^IBA(355.93,IBIEN,"NPISTATUS",0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY374PO 1456 printed Oct 16, 2024@18:34:30 Page 2
IBY374PO ;PRXM/CMW - Post install routine for patch 374 ; 10 May 2007 9:41 AM
+1 ;;2.0;INTEGRATED BILLING;**374**;21-MAR-94;Build 16
+2 ;
+3 ; Call at tags only
+4 QUIT
+5 ; This routine will clean up entries in the file with NPIs delete status (2)
+6 ;
EN ; Post Install Routine primary entry point
+1 ;
+2 DO DEL
+3 DO CLEAN
+4 QUIT
+5 ;
DEL ; Look for NPI with delete status of "2"
+1 NEW IBIEN,STA,DA,IBOLDNPI
+2 SET IBIEN=0
+3 FOR
SET IBIEN=$ORDER(^IBA(355.93,IBIEN))
if 'IBIEN
QUIT
Begin DoDot:1
+4 SET DA="A"
+5 ; Loop through deleted NPIs (Status "2")
+6 SET STA=2
+7 FOR
SET DA=$ORDER(^IBA(355.93,IBIEN,"NPISTATUS","NPISTATUS",STA,DA),-1)
if 'DA
QUIT
Begin DoDot:2
+8 SET IBOLDNPI=$PIECE(^IBA(355.93,IBIEN,"NPISTATUS",DA,0),U,3)
+9 DO COMP
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
COMP ;COMPLETELY DELETE THE NPI
+1 ;If NPI has status of "2" remove all entries related to this NPI.
+2 NEW OIEN
+3 SET OIEN="A"
+4 FOR
SET OIEN=$ORDER(^IBA(355.93,IBIEN,"NPISTATUS","C",IBOLDNPI,OIEN),-1)
if 'OIEN
QUIT
Begin DoDot:1
+5 NEW DIE,DIK,DIC,DA,DR,D,D0,DI,DIC,DQ,X
+6 NEW DP,DM,DK,DL,DIEL
+7 SET DA(1)=IBIEN
SET DIK="^IBA(355.93,"_DA(1)_",""NPISTATUS"","
SET DA=OIEN
+8 DO ^DIK
+9 ; kill 41.01 references
+10 KILL ^IBA(355.93,"NPI",IBOLDNPI,DA),^IBA(355.93,"NPIHISTORY",IBOLDNPI,DA)
End DoDot:1
+11 QUIT
+12 ;
CLEAN ; Clean up ^IBA(355.93,IEN,"NPISTATUS",0) if there are no multiples in the sub-file.
+1 NEW IBIEN
+2 SET IBIEN=0
+3 FOR
SET IBIEN=$ORDER(^IBA(355.93,IBIEN))
if 'IBIEN
QUIT
Begin DoDot:1
+4 if $GET(^IBA(355.93,IBIEN,"NPISTATUS",0))=""
QUIT
+5 IF +$PIECE($GET(^IBA(355.93,IBIEN,"NPISTATUS",0)),U,4)=0
Begin DoDot:2
+6 KILL ^IBA(355.93,IBIEN,"NPISTATUS",0)
End DoDot:2
End DoDot:1
+7 QUIT
