IBY764PO ;SAB/EDE - IB*2.0*764 POST INSTALL;03/31/22 12:35pm
;;2.0;Integrated Billing;**764**;Mar 20, 1995;Build 2
;Per VA Directive 6402, this routine should not be modified.
Q
;
EN ;Post Install for IB*2.0*764
D BMES^XPDUTL(" >> Starting the Post-Initialization routine for IB*2.0*764")
D NEWCREAS
D BMES^XPDUTL(" >> End of the Post-Initialization routine for IB*2.0*764")
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) ; Can Cancel UC
. ;Not needed for this round of Cancellation Reason Creations.
. ;S DR=DR_";.05////"_$P(IBDATA,";",7) ; UC Visit Processing
. ;
. S DIE="^IBE(350.3,",DA=LIEN
. D ^DIE
. K DR
Q
;
REASDAT ; Cleland Dole
;;CLELAND-DOLE;C-D;3;Y;2
;;END
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY764PO 1671 printed Dec 13, 2024@02:35:26 Page 2
IBY764PO ;SAB/EDE - IB*2.0*764 POST INSTALL;03/31/22 12:35pm
+1 ;;2.0;Integrated Billing;**764**;Mar 20, 1995;Build 2
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
EN ;Post Install for IB*2.0*764
+1 DO BMES^XPDUTL(" >> Starting the Post-Initialization routine for IB*2.0*764")
+2 DO NEWCREAS
+3 DO BMES^XPDUTL(" >> End of the Post-Initialization routine for IB*2.0*764")
+4 QUIT
+5 ;
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 ; Can Cancel UC
SET DR=DR_";.05///"_$PIECE(IBDATA,";",7)
+24 ;Not needed for this round of Cancellation Reason Creations.
+25 ;S DR=DR_";.05////"_$P(IBDATA,";",7) ; UC Visit Processing
+26 ;
+27 SET DIE="^IBE(350.3,"
SET DA=LIEN
+28 DO ^DIE
+29 KILL DR
End DoDot:1
+30 QUIT
+31 ;
REASDAT ; Cleland Dole
+1 ;;CLELAND-DOLE;C-D;3;Y;2
+2 ;;END
+3 QUIT
+4 ;
