IBY770PRE ;EDE/TPF - PRE-INSTALL FOR IB*2.0*770 ;
;;2.0;INTEGRATED BILLING;**770**;21-MAR-94;Build 119
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
;D PRETR^IBY770PRE
PRETR ;EP - PRE-TRANSPORT ROUTINE
;
D BMES(" "),BMES("Entering PRE-TRANSPORT routine.....")
;
N ASSIGNIEN
;
K @XPDGREF@(XPDNM)
;
D BMES^XPDUTL("Saving #364.92 ACC ACTIVITY CODES file entries.")
;
M @XPDGREF@(XPDNM,364.92)=^IBA(364.92)
;
S ASSIGNIEN=0 F S ASSIGNIEN=$O(@XPDGREF@(XPDNM,364.92,ASSIGNIEN)) Q:'ASSIGNIEN D PULL(ASSIGNIEN)
;
D BMES("Leaving PRE-TRANSPORT routine.....")
;
Q
;
PULL(ASSIGNIEN) ;EP - SET TRANSPORT TEMP GLOBAL UP WITH ACC ACTIVITY CODES ENTRIES
;
N ASSGNGRPIEN,ASSOCACTIEN,ASSOCACTPTR,ASSOCACTNAME
;
S ASSGNGRPIEN=0 ;LOOP THROUGH ASSIGNING GROUP
F S ASSGNGRPIEN=$O(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN)) Q:'ASSGNGRPIEN D
.S ASSOCACTIEN=0 ;LOOP THROUGH ASSOCIATED ACTION ITEMS
.F S ASSOCACTIEN=$O(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,ASSOCACTIEN)) Q:'ASSOCACTIEN D
..S ASSOCACTPTR=$P($G(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,ASSOCACTIEN,0)),U)
..Q:$G(ASSOCACTPTR)=""
..S ASSOCACTNAME=$P($G(^ORD(101,ASSOCACTPTR,0)),U)
..Q:$G(ASSOCACTNAME)=""
..S $P(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,ASSOCACTIEN,0),U)=ASSOCACTNAME
..K @XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,"B",ASSOCACTPTR)
;
Q
;
;POST TRANSPORT CALLED FROM IBY770PO
;D PUT^IBY770PRE
PUT ;EP - PLACE TRANSPORT GLOABL #364.92 DATA INTO #364.92 PROPER
;
D BMES(" "),BMES("Updating file #364.92 ACC ACTIVITY CODES file.....")
;
;TPF;IB2*770v24 REMOVE OLD ENTRIES
N DA
N DIK ; WCJ;SQA;V47
S DIK="^IBA(364.92,"
S DA=0
F S DA=$O(^IBA(364.92,DA)) Q:'DA D
.D ^DIK
;TPF;IB2*770v24 END REMOVE OLD ENTRIES
;
;LOOP THROUGH THE SOURCE AND RESOLVE POINTERS BEFORE MERGIN INTO THE DATA GLOBAL
N ASSGNGRPIEN,ASSOCACTIEN,ASSOCACTPTR,ASSOCACTNAME
;
S ASSIGNIEN=0 F S ASSIGNIEN=$O(@XPDGREF@(XPDNM,364.92,ASSIGNIEN)) Q:'ASSIGNIEN D
.S ASSGNGRPIEN=0 ;LOOP THROUGH ASSIGNING GROUP
.F S ASSGNGRPIEN=$O(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN)) Q:'ASSGNGRPIEN D
..S ASSOCACTIEN=0 ;LOOP THROUGH ASSOCIATED ACTION ITEMS
..F S ASSOCACTIEN=$O(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,ASSOCACTIEN)) Q:'ASSOCACTIEN D
...S ASSOCACTNAME=$P($G(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,ASSOCACTIEN,0)),U)
...Q:ASSOCACTNAME=""
...S ASSOCACTPTR=$O(^ORD(101,"B",ASSOCACTNAME,""))
...I 'ASSOCACTPTR D Q
....D BMES(" ASSOCIATED ACTION PROTOCOL POINTER NOT FOUND!!")
...S $P(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,ASSOCACTIEN,0),U)=ASSOCACTPTR
...S @XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,"B",ASSOCACTPTR,ASSOCACTIEN)=""
;
M ^IBA(364.92)=@XPDGREF@(XPDNM,364.92)
;
D BMES(" "),BMES("Finished updating file #364.92 ACC ACTIVITY CODES file.....")
;
Q
;
BMES(STR) ;
;
D BMES^XPDUTL($$TRIM^XLFSTR($$CJ^XLFSTR(STR,$G(IOM,80)),"R"," "))
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY770PRE 3063 printed May 25, 2026@12:40:37 Page 2
IBY770PRE ;EDE/TPF - PRE-INSTALL FOR IB*2.0*770 ;
+1 ;;2.0;INTEGRATED BILLING;**770**;21-MAR-94;Build 119
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
+6 ;D PRETR^IBY770PRE
PRETR ;EP - PRE-TRANSPORT ROUTINE
+1 ;
+2 DO BMES(" ")
DO BMES("Entering PRE-TRANSPORT routine.....")
+3 ;
+4 NEW ASSIGNIEN
+5 ;
+6 KILL @XPDGREF@(XPDNM)
+7 ;
+8 DO BMES^XPDUTL("Saving #364.92 ACC ACTIVITY CODES file entries.")
+9 ;
+10 MERGE @XPDGREF@(XPDNM,364.92)=^IBA(364.92)
+11 ;
+12 SET ASSIGNIEN=0
FOR
SET ASSIGNIEN=$ORDER(@XPDGREF@(XPDNM,364.92,ASSIGNIEN))
if 'ASSIGNIEN
QUIT
DO PULL(ASSIGNIEN)
+13 ;
+14 DO BMES("Leaving PRE-TRANSPORT routine.....")
+15 ;
+16 QUIT
+17 ;
PULL(ASSIGNIEN) ;EP - SET TRANSPORT TEMP GLOBAL UP WITH ACC ACTIVITY CODES ENTRIES
+1 ;
+2 NEW ASSGNGRPIEN,ASSOCACTIEN,ASSOCACTPTR,ASSOCACTNAME
+3 ;
+4 ;LOOP THROUGH ASSIGNING GROUP
SET ASSGNGRPIEN=0
+5 FOR
SET ASSGNGRPIEN=$ORDER(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN))
if 'ASSGNGRPIEN
QUIT
Begin DoDot:1
+6 ;LOOP THROUGH ASSOCIATED ACTION ITEMS
SET ASSOCACTIEN=0
+7 FOR
SET ASSOCACTIEN=$ORDER(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,ASSOCACTIEN))
if 'ASSOCACTIEN
QUIT
Begin DoDot:2
+8 SET ASSOCACTPTR=$PIECE($GET(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,ASSOCACTIEN,0)),U)
+9 if $GET(ASSOCACTPTR)=""
QUIT
+10 SET ASSOCACTNAME=$PIECE($GET(^ORD(101,ASSOCACTPTR,0)),U)
+11 if $GET(ASSOCACTNAME)=""
QUIT
+12 SET $PIECE(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,ASSOCACTIEN,0),U)=ASSOCACTNAME
+13 KILL @XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,"B",ASSOCACTPTR)
End DoDot:2
End DoDot:1
+14 ;
+15 QUIT
+16 ;
+17 ;POST TRANSPORT CALLED FROM IBY770PO
+18 ;D PUT^IBY770PRE
PUT ;EP - PLACE TRANSPORT GLOABL #364.92 DATA INTO #364.92 PROPER
+1 ;
+2 DO BMES(" ")
DO BMES("Updating file #364.92 ACC ACTIVITY CODES file.....")
+3 ;
+4 ;TPF;IB2*770v24 REMOVE OLD ENTRIES
+5 NEW DA
+6 ; WCJ;SQA;V47
NEW DIK
+7 SET DIK="^IBA(364.92,"
+8 SET DA=0
+9 FOR
SET DA=$ORDER(^IBA(364.92,DA))
if 'DA
QUIT
Begin DoDot:1
+10 DO ^DIK
End DoDot:1
+11 ;TPF;IB2*770v24 END REMOVE OLD ENTRIES
+12 ;
+13 ;LOOP THROUGH THE SOURCE AND RESOLVE POINTERS BEFORE MERGIN INTO THE DATA GLOBAL
+14 NEW ASSGNGRPIEN,ASSOCACTIEN,ASSOCACTPTR,ASSOCACTNAME
+15 ;
+16 SET ASSIGNIEN=0
FOR
SET ASSIGNIEN=$ORDER(@XPDGREF@(XPDNM,364.92,ASSIGNIEN))
if 'ASSIGNIEN
QUIT
Begin DoDot:1
+17 ;LOOP THROUGH ASSIGNING GROUP
SET ASSGNGRPIEN=0
+18 FOR
SET ASSGNGRPIEN=$ORDER(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN))
if 'ASSGNGRPIEN
QUIT
Begin DoDot:2
+19 ;LOOP THROUGH ASSOCIATED ACTION ITEMS
SET ASSOCACTIEN=0
+20 FOR
SET ASSOCACTIEN=$ORDER(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,ASSOCACTIEN))
if 'ASSOCACTIEN
QUIT
Begin DoDot:3
+21 SET ASSOCACTNAME=$PIECE($GET(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,ASSOCACTIEN,0)),U)
+22 if ASSOCACTNAME=""
QUIT
+23 SET ASSOCACTPTR=$ORDER(^ORD(101,"B",ASSOCACTNAME,""))
+24 IF 'ASSOCACTPTR
Begin DoDot:4
+25 DO BMES(" ASSOCIATED ACTION PROTOCOL POINTER NOT FOUND!!")
End DoDot:4
QUIT
+26 SET $PIECE(@XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,ASSOCACTIEN,0),U)=ASSOCACTPTR
+27 SET @XPDGREF@(XPDNM,364.92,ASSIGNIEN,5,ASSGNGRPIEN,15,"B",ASSOCACTPTR,ASSOCACTIEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+28 ;
+29 MERGE ^IBA(364.92)=@XPDGREF@(XPDNM,364.92)
+30 ;
+31 DO BMES(" ")
DO BMES("Finished updating file #364.92 ACC ACTIVITY CODES file.....")
+32 ;
+33 QUIT
+34 ;
BMES(STR) ;
+1 ;
+2 DO BMES^XPDUTL($$TRIM^XLFSTR($$CJ^XLFSTR(STR,$GET(IOM,80)),"R"," "))
+3 ;
+4 QUIT
