IB20P533 ;ALB/RRA - UPDATE IIV TRANSMISSION QUEUE ; 11/5/14 9:28am
;;2.0;INTEGRATED BILLING;**533**;21-MAR-94;Build 5
;;Per VA Directive 6402, this routine should not be modified.
Q
PRE ;
; Update IIV TRANSMISSION QUEUE file (#365.1)
D MES^XPDUTL("Starting IB*2*533 Pre-Install....")
D UPDATE
D MES^XPDUTL("Patch Pre-Install is complete.")
Q
;
UPDATE ;
N IBCN0,IBINS,IBWE,IBCNO,IBSD,IBCNT,IBNOW,IBX,IBQF
S IBX=0,IBCNT=0
;LOOP THROUGH TRANSMISSION STATUS TO FIND RECORDS "READY TO TRASMIT"
D MES^XPDUTL(""),MES^XPDUTL(">>>Processing records.....""")
F S IBX=$O(^IBCN(365.1,"AC",1,IBX)) Q:IBX="" D
. S IBCN0=$G(^IBCN(365.1,IBX,0)),IBQF=$P($G(IBCN0),"^",11)
. I IBQF="I" D FILE Q
. S IBINS=$P($G(IBCN0),"^",13),IBWE=$P($G(IBCN0),"^",10),IBSD=$P($G(IBCN0),"^",12),IBNOW=$$NOW^XLFDT
. ;QUIT UNLESS THE EXTRACT IS FOR APPOINTMENT (2)
. Q:IBWE'=2
. ;QUIT UNLESS THE SERVICE DATE IS IN PAST
. Q:IBSD>IBNOW
. ;THE REMAINING RECORDS NEED TO BE CANCELLED AND UPDATED WITH A STATUS DATE OF "NOW"
. D FILE Q
;process "Hold" records with query flag = Identification
S IBX=0
F S IBX=$O(^IBCN(365.1,"AC",4,IBX)) Q:IBX="" D
. I $P($G(^IBCN(365.1,IBX,0)),"^",11)="I" D FILE
. Q
;process "Retry" records with query flag = Identification
S IBX=0
F S IBX=$O(^IBCN(365.1,"AC",6,IBX)) Q:IBX="" D
. I $P($G(^IBCN(365.1,IBX,0)),"^",11)="I" D FILE
. Q
;
D MES^XPDUTL("Total of "_IBCNT_" code"_$S(IBCNT'=1:"s",1:"")_" updated in the IIV TRANSMISSION QUEUE file (#365.1)")
D MES^XPDUTL("")
Q
;FILE UPDATE
FILE ;
N DA,DIE,DR,X,Y
S IBNOW=$$NOW^XLFDT
S DIE="^IBCN(365.1,",DA=IBX,DR=".04///"_"Cancelled"_";.15///"_IBNOW D ^DIE
S IBCNT=IBCNT+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P533 1713 printed Dec 13, 2024@02:03:31 Page 2
IB20P533 ;ALB/RRA - UPDATE IIV TRANSMISSION QUEUE ; 11/5/14 9:28am
+1 ;;2.0;INTEGRATED BILLING;**533**;21-MAR-94;Build 5
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
PRE ;
+1 ; Update IIV TRANSMISSION QUEUE file (#365.1)
+2 DO MES^XPDUTL("Starting IB*2*533 Pre-Install....")
+3 DO UPDATE
+4 DO MES^XPDUTL("Patch Pre-Install is complete.")
+5 QUIT
+6 ;
UPDATE ;
+1 NEW IBCN0,IBINS,IBWE,IBCNO,IBSD,IBCNT,IBNOW,IBX,IBQF
+2 SET IBX=0
SET IBCNT=0
+3 ;LOOP THROUGH TRANSMISSION STATUS TO FIND RECORDS "READY TO TRASMIT"
+4 DO MES^XPDUTL("")
DO MES^XPDUTL(">>>Processing records.....""")
+5 FOR
SET IBX=$ORDER(^IBCN(365.1,"AC",1,IBX))
if IBX=""
QUIT
Begin DoDot:1
+6 SET IBCN0=$GET(^IBCN(365.1,IBX,0))
SET IBQF=$PIECE($GET(IBCN0),"^",11)
+7 IF IBQF="I"
DO FILE
QUIT
+8 SET IBINS=$PIECE($GET(IBCN0),"^",13)
SET IBWE=$PIECE($GET(IBCN0),"^",10)
SET IBSD=$PIECE($GET(IBCN0),"^",12)
SET IBNOW=$$NOW^XLFDT
+9 ;QUIT UNLESS THE EXTRACT IS FOR APPOINTMENT (2)
+10 if IBWE'=2
QUIT
+11 ;QUIT UNLESS THE SERVICE DATE IS IN PAST
+12 if IBSD>IBNOW
QUIT
+13 ;THE REMAINING RECORDS NEED TO BE CANCELLED AND UPDATED WITH A STATUS DATE OF "NOW"
+14 DO FILE
QUIT
End DoDot:1
+15 ;process "Hold" records with query flag = Identification
+16 SET IBX=0
+17 FOR
SET IBX=$ORDER(^IBCN(365.1,"AC",4,IBX))
if IBX=""
QUIT
Begin DoDot:1
+18 IF $PIECE($GET(^IBCN(365.1,IBX,0)),"^",11)="I"
DO FILE
+19 QUIT
End DoDot:1
+20 ;process "Retry" records with query flag = Identification
+21 SET IBX=0
+22 FOR
SET IBX=$ORDER(^IBCN(365.1,"AC",6,IBX))
if IBX=""
QUIT
Begin DoDot:1
+23 IF $PIECE($GET(^IBCN(365.1,IBX,0)),"^",11)="I"
DO FILE
+24 QUIT
End DoDot:1
+25 ;
+26 DO MES^XPDUTL("Total of "_IBCNT_" code"_$SELECT(IBCNT'=1:"s",1:"")_" updated in the IIV TRANSMISSION QUEUE file (#365.1)")
+27 DO MES^XPDUTL("")
+28 QUIT
+29 ;FILE UPDATE
FILE ;
+1 NEW DA,DIE,DR,X,Y
+2 SET IBNOW=$$NOW^XLFDT
+3 SET DIE="^IBCN(365.1,"
SET DA=IBX
SET DR=".04///"_"Cancelled"_";.15///"_IBNOW
DO ^DIE
+4 SET IBCNT=IBCNT+1
+5 QUIT
