- 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 Feb 19, 2025@00:01:55 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 ;