IBY797PO ;YMG/EDE - IB*2.0*797 POST INSTALL;FEB 16 2024
;;2.0;Integrated Billing;**797**;21-MAR-94;Build 2
;Per VA Directive 6402, this routine should not be modified.
;
Q
;
EN ; entry point
D BMES^XPDUTL(" >> Starting the Post-Initialization routine for IB*2.0*797")
D NEWCANC
D UPDCANC
D BMES^XPDUTL(" >> End of the Post-Initialization routine for IB*2.0*797")
Q
;
NEWCANC ; add new cancellation reason to file 350.3
N FDA,IBCNNM
D MES^XPDUTL(" -> Adding new Cancellation Reason to file 350.3...")
S IBCNNM="INCORRECT CLINIC/STOP CODE"
I $$FIND1^DIC(350.3,,"X",IBCNNM,"B")>0 D MES^XPDUTL(" Already exists.") Q ; already exists
S FDA(350.3,"+1,",.01)=IBCNNM ; name
S FDA(350.3,"+1,",.02)="ICS" ; abbreviation
S FDA(350.3,"+1,",.03)=3 ; limit
S FDA(350.3,"+1,",.07)=1 ; MH visit processing
S FDA(350.3,"+1,",.08)=1 ; Can cancel MH Visit
D UPDATE^DIE("","FDA")
D MES^XPDUTL(" Done.")
Q
;
UPDCANC ; update fields .09 and .1 in file 350.3
N FDA,IBCNNM,IBDATA,IBEFDT,IBENDT,IBIEN,IENS,Z
D MES^XPDUTL(" -> initializing EFFECTIVE DATE and END DATE fields in file 350.3...")
F Z=1:1 S IBDATA=$T(REASDAT+Z),IBCNNM=$P(IBDATA,";",3) Q:IBCNNM="END" D
.S IBEFDT=$P(IBDATA,";",4),IBENDT=$P(IBDATA,";",5)
.S IBIEN=$O(^IBE(350.3,"B",IBCNNM,""))
.I 'IBIEN D BMES^XPDUTL(" >> Unable to update the Charge Remove Reason "_IBCNNM_".") Q
.S IENS=IBIEN_","
.S FDA(350.3,IENS,.09)=IBEFDT
.I IBENDT>0 S FDA(350.3,IENS,.1)=IBENDT
.D FILE^DIE("","FDA") K FDA
.Q
D MES^XPDUTL(" Done.")
Q
;
REASDAT ; Cancellation reasons (350.3) to update
;;AI/AN VERIFIED;3220105
;;CLELAND-DOLE;3230627;3271231
;;COMPACT;3230117
;;HANNON ACT;3220919;3250918
;;MEDAL OF HONOR;3161216
;;PACT103;3240305
;;PANDEMIC RESPONSE;3200301;3210930
;;UC - CHANGE IN ELIGIBILITY;3190606
;;UC - DUPLICATE VISIT;3190606
;;UC - ENTERED IN ERROR;3190606
;;UC - PG6 REVIEWED;3190606
;;UC - SEQUENCE UPDATE;3190606
;;WORLD WAR II;3230325
;;END
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBY797PO 2055 printed Dec 13, 2024@02:35:34 Page 2
IBY797PO ;YMG/EDE - IB*2.0*797 POST INSTALL;FEB 16 2024
+1 ;;2.0;Integrated Billing;**797**;21-MAR-94;Build 2
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
EN ; entry point
+1 DO BMES^XPDUTL(" >> Starting the Post-Initialization routine for IB*2.0*797")
+2 DO NEWCANC
+3 DO UPDCANC
+4 DO BMES^XPDUTL(" >> End of the Post-Initialization routine for IB*2.0*797")
+5 QUIT
+6 ;
NEWCANC ; add new cancellation reason to file 350.3
+1 NEW FDA,IBCNNM
+2 DO MES^XPDUTL(" -> Adding new Cancellation Reason to file 350.3...")
+3 SET IBCNNM="INCORRECT CLINIC/STOP CODE"
+4 ; already exists
IF $$FIND1^DIC(350.3,,"X",IBCNNM,"B")>0
DO MES^XPDUTL(" Already exists.")
QUIT
+5 ; name
SET FDA(350.3,"+1,",.01)=IBCNNM
+6 ; abbreviation
SET FDA(350.3,"+1,",.02)="ICS"
+7 ; limit
SET FDA(350.3,"+1,",.03)=3
+8 ; MH visit processing
SET FDA(350.3,"+1,",.07)=1
+9 ; Can cancel MH Visit
SET FDA(350.3,"+1,",.08)=1
+10 DO UPDATE^DIE("","FDA")
+11 DO MES^XPDUTL(" Done.")
+12 QUIT
+13 ;
UPDCANC ; update fields .09 and .1 in file 350.3
+1 NEW FDA,IBCNNM,IBDATA,IBEFDT,IBENDT,IBIEN,IENS,Z
+2 DO MES^XPDUTL(" -> initializing EFFECTIVE DATE and END DATE fields in file 350.3...")
+3 FOR Z=1:1
SET IBDATA=$TEXT(REASDAT+Z)
SET IBCNNM=$PIECE(IBDATA,";",3)
if IBCNNM="END"
QUIT
Begin DoDot:1
+4 SET IBEFDT=$PIECE(IBDATA,";",4)
SET IBENDT=$PIECE(IBDATA,";",5)
+5 SET IBIEN=$ORDER(^IBE(350.3,"B",IBCNNM,""))
+6 IF 'IBIEN
DO BMES^XPDUTL(" >> Unable to update the Charge Remove Reason "_IBCNNM_".")
QUIT
+7 SET IENS=IBIEN_","
+8 SET FDA(350.3,IENS,.09)=IBEFDT
+9 IF IBENDT>0
SET FDA(350.3,IENS,.1)=IBENDT
+10 DO FILE^DIE("","FDA")
KILL FDA
+11 QUIT
End DoDot:1
+12 DO MES^XPDUTL(" Done.")
+13 QUIT
+14 ;
REASDAT ; Cancellation reasons (350.3) to update
+1 ;;AI/AN VERIFIED;3220105
+2 ;;CLELAND-DOLE;3230627;3271231
+3 ;;COMPACT;3230117
+4 ;;HANNON ACT;3220919;3250918
+5 ;;MEDAL OF HONOR;3161216
+6 ;;PACT103;3240305
+7 ;;PANDEMIC RESPONSE;3200301;3210930
+8 ;;UC - CHANGE IN ELIGIBILITY;3190606
+9 ;;UC - DUPLICATE VISIT;3190606
+10 ;;UC - ENTERED IN ERROR;3190606
+11 ;;UC - PG6 REVIEWED;3190606
+12 ;;UC - SEQUENCE UPDATE;3190606
+13 ;;WORLD WAR II;3230325
+14 ;;END
+15 QUIT
