IB20P734 ;SAB/EDE - IB*2.0*734 POST INSTALL;07/25/22 12:35pm
;;2.0;Integrated Billing;**734**;Mar 20, 1995;Build 4
;Per VA Directive 6402, this routine should not be modified.
Q
;
POSTINIT ;Post Install for IB*2.0*734
D BMES^XPDUTL(" >> Starting the Post-Initialization routine for IB*2.0*734")
D NEWCREAS
D BMES^XPDUTL(" >> End of the Post-Initialization routine for IB*2.0*734")
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
. ;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 ; Fee Service to inactivate
;;REGISTRY EXAM;REXAM;3;N
;;END
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P734 1635 printed Dec 13, 2024@02:04:43 Page 2
IB20P734 ;SAB/EDE - IB*2.0*734 POST INSTALL;07/25/22 12:35pm
+1 ;;2.0;Integrated Billing;**734**;Mar 20, 1995;Build 4
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
POSTINIT ;Post Install for IB*2.0*734
+1 DO BMES^XPDUTL(" >> Starting the Post-Initialization routine for IB*2.0*734")
+2 DO NEWCREAS
+3 DO BMES^XPDUTL(" >> End of the Post-Initialization routine for IB*2.0*734")
+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 ;Not needed for this round of Cancellation Reason Creations.
+24 ;S DR=DR_";.05////"_$P(IBDATA,";",7) ; UC Visit Processing
+25 ;
+26 SET DIE="^IBE(350.3,"
SET DA=LIEN
+27 DO ^DIE
+28 KILL DR
End DoDot:1
+29 QUIT
+30 ;
REASDAT ; Fee Service to inactivate
+1 ;;REGISTRY EXAM;REXAM;3;N
+2 ;;END
+3 QUIT
+4 ;
