IB20P709 ;SAB/EDE - IB*2.0*709 POST INSTALL;03/10/20 2:10pm
;;2.0;Integrated Billing;**709**;Mar 20, 1995;Build 14
;Per VA Directive 6402, this routine should not be modified.
Q
;
POSTINIT ;Post Install for IB*2.0*709
D BMES^XPDUTL(" >> Starting the Post-Initialization routine for IB*2.0*709")
D SETPARAM
D NEWCREAS
D BMES^XPDUTL(" >> End of the Post-Initialization routine for IB*2.0*709")
Q
;
SETPARAM ; set default value for IB site parameter 350.9/71.02
N DA,DIE,DR,X,Y
D MES^XPDUTL("Setting default start date for COMPACT ACT Benefit in IB SITE PARAMETER file...")
S DA=1,DIE=350.9,DR="71.02///^S X=3210901" D ^DIE
D MES^XPDUTL("Done.")
Q
;
NEWCREAS ; New Cancellation Reasons
N LOOP,LIEN,IBDATA,IBCNNM
N X,Y,DIE,DA,DR,DTOUT,DATA,IBDATAB,DIK
;
N CANIEN,UPDIEN,SVCIEN,CHGIEN
;
; Grab all of the entries to update
D MES^XPDUTL(" -> Adding new Cancellation Reason to the IB CHARGE REMOVE REASON file (350.3).")
S Y=-1
F LOOP=1:1 S IBDATA=$T(REASDAT+LOOP) Q:$P(IBDATA,";",3)="END" D
. S DR=""
. ;Extract the new ACTION TYPE to be added.
. ;Store in array for adding to the file (#350.1).
. Q:IBDATA="" ;go to next entry if Category is not to be updated.
. ;
. S IBCNNM=$P(IBDATA,";",3)
. S LIEN=$O(^IBE(350.3,"B",IBCNNM,""))
. ; File the update along with inactivate the ACTION TYPE
. S DLAYGO=350.3,DIC="^IBE(350.3,",DIC(0)="L",X=IBCNNM
. I '+LIEN D FILE^DICN S LIEN=+Y K DIC,DINUM,DLAYGO
. S DR=".02////"_$P(IBDATA,";",4) ; ABBREVIATION
. S DR=DR_";.03////"_$P(IBDATA,";",5) ; LIMIT
. S DR=DR_";.04///"_$P(IBDATA,";",6) ; Can Cancel UC
. S DR=DR_";.05////"_$P(IBDATA,";",7) ; UC Visit Processing
. ;
. S DIE="^IBE(350.3,",DA=LIEN
. D ^DIE
. K DR
Q
;
REASDAT ; Fee Service to inactivate
;;COMPACT;CMPCT;3;Y;1
;;END
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P709 1841 printed Dec 13, 2024@02:04:39 Page 2
IB20P709 ;SAB/EDE - IB*2.0*709 POST INSTALL;03/10/20 2:10pm
+1 ;;2.0;Integrated Billing;**709**;Mar 20, 1995;Build 14
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
POSTINIT ;Post Install for IB*2.0*709
+1 DO BMES^XPDUTL(" >> Starting the Post-Initialization routine for IB*2.0*709")
+2 DO SETPARAM
+3 DO NEWCREAS
+4 DO BMES^XPDUTL(" >> End of the Post-Initialization routine for IB*2.0*709")
+5 QUIT
+6 ;
SETPARAM ; set default value for IB site parameter 350.9/71.02
+1 NEW DA,DIE,DR,X,Y
+2 DO MES^XPDUTL("Setting default start date for COMPACT ACT Benefit in IB SITE PARAMETER file...")
+3 SET DA=1
SET DIE=350.9
SET DR="71.02///^S X=3210901"
DO ^DIE
+4 DO MES^XPDUTL("Done.")
+5 QUIT
+6 ;
NEWCREAS ; New Cancellation Reasons
+1 NEW LOOP,LIEN,IBDATA,IBCNNM
+2 NEW X,Y,DIE,DA,DR,DTOUT,DATA,IBDATAB,DIK
+3 ;
+4 NEW CANIEN,UPDIEN,SVCIEN,CHGIEN
+5 ;
+6 ; Grab all of the entries to update
+7 DO MES^XPDUTL(" -> Adding new Cancellation Reason to the IB CHARGE REMOVE REASON file (350.3).")
+8 SET Y=-1
+9 FOR LOOP=1:1
SET IBDATA=$TEXT(REASDAT+LOOP)
if $PIECE(IBDATA,";",3)="END"
QUIT
Begin DoDot:1
+10 SET DR=""
+11 ;Extract the new ACTION TYPE to be added.
+12 ;Store in array for adding to the file (#350.1).
+13 ;go to next entry if Category is not to be updated.
if IBDATA=""
QUIT
+14 ;
+15 SET IBCNNM=$PIECE(IBDATA,";",3)
+16 SET LIEN=$ORDER(^IBE(350.3,"B",IBCNNM,""))
+17 ; File the update along with inactivate the ACTION TYPE
+18 SET DLAYGO=350.3
SET DIC="^IBE(350.3,"
SET DIC(0)="L"
SET X=IBCNNM
+19 IF '+LIEN
DO FILE^DICN
SET LIEN=+Y
KILL DIC,DINUM,DLAYGO
+20 ; ABBREVIATION
SET DR=".02////"_$PIECE(IBDATA,";",4)
+21 ; LIMIT
SET DR=DR_";.03////"_$PIECE(IBDATA,";",5)
+22 ; Can Cancel UC
SET DR=DR_";.04///"_$PIECE(IBDATA,";",6)
+23 ; UC Visit Processing
SET DR=DR_";.05////"_$PIECE(IBDATA,";",7)
+24 ;
+25 SET DIE="^IBE(350.3,"
SET DA=LIEN
+26 DO ^DIE
+27 KILL DR
End DoDot:1
+28 QUIT
+29 ;
REASDAT ; Fee Service to inactivate
+1 ;;COMPACT;CMPCT;3;Y;1
+2 ;;END
+3 QUIT
+4 ;
