IBCNFSND ;WOIFO/PO - Electronic Insurance Identification ;12/23/2011
;;2.0;INTEGRATED BILLING;**457**;21-MAR-94;Build 30
;;Per VHA Directive 2004-038, this routine should not be modified.
;;
;
; Sending Extract files and checking status of file transfers.
;
Q
;
SENDEII ; send HMS extract files and check status of files transfers.
; this subroutine is called from IBAMTC routine which is an scheduled job running once a day.
;
N IBNOTREC,IBNOEXT,IBCNFPAR,IBCRDT,IBD0,IBD1,IBEXTNOD,IBFARR,IBFILE,IBFLIST,IBFROM,IBFSPEC,IBMSGNUM,IBNOEXT
N IBNUMMSG,IBNUMREC,IBPSTDUE,IBSUB1,IBTEXT,IBTO,IBXMSUB,IBXMY,IBNORES,IBMAXREC,IBAKEEP,IBXMZ
N X,Y,DA,DIC,DIK,D0,D1,D2,DG,DI,DIW,DICR,DIE,DLAYGO,DQ,DR,XMDUN,XMZ,IBFILEX,FNDFILE,FNDFILES
; get the IB configuration parameters and list of active extract files.
D GETPARAM^IBCNFRD(.IBCNFPAR)
;
I 'IBCNFPAR(13.02) QUIT ; if eII active field is not 1 quit.
;
S IBMAXREC=255 ; message's maximum record line legth
S IBAKEEP=6*30 ; number of days to keep the activity logs before get purged.
S IBTEXT="^TMP(""IBCNFCND_IBTEXT"",$J)" ; @IBTEXT@(1:nnn) array to store the extract file content.
K @IBTEXT
;
; for each active extracted HMS file name.
S IBSUB1=0
F S IBSUB1=$O(IBCNFPAR(13.08,IBSUB1)) Q:'IBSUB1 D
. S IBEXTNOD=IBCNFPAR(13.08,IBSUB1)
. S IBFILE=$P(IBEXTNOD,U,3) ; extract file name
. ;
. K DIC S DIC="^IBA(355.35,",DIC(0)="QZL",X=$P(IBEXTNOD,U,1) D ^DIC
. S IBD0=+Y
. S IBCRDT=$P(Y(0),U,2) ;creation date time.
. I 'IBCRDT S IBCRDT=$$NOW^XLFDT() ; first time this type is created.
. ;
. ; Check message sub-file for all acknowledgements
. ; want to do this first, so we can get the old ones cleared out
. ; and put in activity log
. ;
. I $O(^IBA(355.35,IBD0,1,0)) D
. . ; if confirmation messages are received for the extract file
. . I $$CHKEXT(IBD0,IBFILE,$P(IBEXTNOD,U,4),.IBNOTREC) D
. . . D CACTLOG(IBD0) ; save the top-level fields of HMS extract file status in the activity log sub-file.
. . . ; kill the messages sub-file.
. . . S DA(1)=IBD0,DA=0
. . . S DIK="^IBA(355.35,"_DA(1)_",1,"
. . . F S DA=$O(^IBA(355.35,IBD0,1,DA)) Q:'DA D ^DIK
. ;
. ; check, if the extract file exits.
. K IBFSPEC,IBFLIST,FNDFILES
. S IBFSPEC(IBFILE)=""
. ;process all the versions of files
. F K IBFLIST S FNDFILE=$$LIST^%ZISH(IBCNFPAR(13.01),"IBFSPEC","IBFLIST") Q:'FNDFILE D
. . S FNDFILES(IBFILE)=""
. . ;Get the full name of the first file found (includes version number for VMS based systems)
. . S IBFILEX=$O(IBFLIST(""))
. . ;
. . ; set the file creation date/time.
. . S DIE="^IBA(355.35,",DA=IBD0,DR=".02///^S X=$$NOW^XLFDT()" D ^DIE
. . ;
. . ; open the eII file and read the content into @IBTEXT@ global and cut the
. . ; records to 255 (IBMAXREC) character chunks if more than 255 (IBMAXREC) characters.
. . D FILERD(IBCNFPAR(13.01),IBFILEX,IBTEXT)
. . ;
. . ; build the file message(s)with the maximum number of lines per message.
. . ; and send the file message(s) to related AITC queue.
. . S IBNUMREC=$O(@IBTEXT@(""),-1) ; number of records
. . S IBNUMMSG=IBNUMREC\IBCNFPAR(13.07) ; number of message to be sent
. . S:IBNUMREC#IBCNFPAR(13.07) IBNUMMSG=IBNUMMSG+1 ; add one message if number records is not multiple of max number of records
. . S:IBNUMMSG<1 IBNUMMSG=1 ; make sure at least one message is sent if the extract file is empty
. . F IBMSGNUM=1:1:IBNUMMSG D
. . . S IBFROM=((IBMSGNUM-1)*IBCNFPAR(13.07)+1)
. . . S IBTO=IBMSGNUM*IBCNFPAR(13.07)
. . . S:IBTO>IBNUMREC IBTO=IBNUMREC
. . . S IBXMSUB="HMS eII Extracted file "_IBFILE_" MSG("_IBMSGNUM_"/"_IBNUMMSG_")"
. . . S IBXMY($P(IBEXTNOD,U,4))="" ; send it to associated ATIC queue address e.g. XXX@Q-IBN.DOMAIN.EXT
. . . S IBXMZ=$$MSGSEND(.IBXMY,IBXMSUB,IBTEXT,IBFROM,IBTO,IBMAXREC)
. . . ;
. . . ; set the purge date for the message in message(#3.9) file
. . . D VAPOR^XMXEDIT(IBXMZ,$$HTFM^XLFDT(+$H+IBAKEEP_","_$P($H,",",2)))
. . . ;
. . . ; record the creation date/time and the time the message(s) were sent in HMS Extract File Status
. . . K DIC S DA(1)=IBD0,DIC(0)="MLF",DLAYGO=355.35
. . . S DIC="^IBA(355.35,"_DA(1)_",1,"
. . . S DIC("DR")=".02///^S X=$$NOW^XLFDT()"
. . . S X=IBXMZ
. . . D FILE^DICN
. . ; delete the file using its full name
. . S IBFARR(IBFILEX)=""
. . S Y=$$DEL^%ZISH(IBCNFPAR(13.01),$NA(IBFARR))
. ;
. I '$D(FNDFILES(IBFILE)) D ;else if extracted file does not exist, save the file name to be reported.
. . S IBPSTDUE=$$FILEDUE^IBCNFSND($P(IBEXTNOD,U,5),$P(IBEXTNOD,U,6),IBCRDT)
. . S:IBPSTDUE IBNOEXT(IBFILE)=""
;
; send an email to IBCNF EII IRM mail group with list of files and messages that their
; confirmation messages are not received within the given time. then re-send the message to ATIC.
I $D(IBNOTREC)>0 D
. D MSGNOTRC^IBCNFSND(.IBNOTREC)
. D RESNDMSG(.IBNOTREC,IBAKEEP)
;
; if extract files are not created withing the give time send an email to IBCNF EII IRM mail group.
I $D(IBNOEXT)>0 D MSGNOEXT^IBCNFSND(.IBNOEXT)
;
; if a Result File is not received within the due time
; Send an email to IBCNF EII IRM mail group
S IBCRDT=+$P($G(^IBA(355.351,1,0)),U,2)
S IBPSTDUE=$$FILEDUE^IBCNFSND(IBCNFPAR(13.04),IBCNFPAR(13.05),IBCRDT)
I IBPSTDUE>0 D MSGNORES^IBCNFSND(IBCNFPAR(13.03))
;
; purge the entries older than 6 months in Activity Log sub-file of
; HMS Extract File Status and HMS Result File Status
D PURGELOG(IBAKEEP) ; purge the activity logs of HMS extract file status and HMS result file status
;
K @IBTEXT
;
Q
;
FILEDUE(IBDUEDAY,IBLTDAY,IBCRDT,IBNOW) ; check if file is due
; input: IBDEUDAY - day of the month the file is due
; IBLTDAY - number of days after day of month to declare file is late
; IBCRDT - date/time last file was processed
; output: 1 - if file is due
; 0 - if file is not due
;
N IBLDM,IBDUEDT,IBLATEDT,LATE,PREVDUE,IBFDOM,IBPFDOM,PLATEDT
S IBNOW=$G(IBNOW,$$NOW^XLFDT())
S LATE=0
; if day of month file due day is 0 retrun 0, since this is as needed file.
I 'IBDUEDAY Q LATE ; do not check assume not past due.
S IBNOW=IBNOW\1 ; current date
S IBCRDT=IBCRDT\1
;
; calculate the due date and passed due late date.
S IBLDM=$E($$SCH^XLFDT("1M(L@1A)",IBNOW)\1,6,7) ; last day of month
I IBDUEDAY>IBLDM S IBDUEDAY=IBLDM ; if due day greater than last day of currnt month set it to last date of current month.
S IBDUEDT=$E(IBNOW,1,5)_$S($L(IBDUEDAY)>1:IBDUEDAY,1:"0"_IBDUEDAY)
S IBLATEDT=$$FMADD^XLFDT(IBDUEDT,IBLTDAY) ; calculate late date
;FIRST OF THIS MONTH
S IBFDOM=$E(IBNOW,1,5)_"01"
;MINUS ONE GETS LAST DAY OF PREVIOUS MONTH
S IBLDMP=$$HTFM^XLFDT($$FMTH^XLFDT(IBFDOM,1)-1,1)
; SETUP FIRST DAY OF PREV MONTH TO CALCULATE DUE DATE OF PREV MONTH
S IBPFDOM=$E(IBLDMP,1,5)_"01"
;NOW CALCULATE DUE DATE OF PREV MONTH
S PREVDUE=$E(IBPFDOM,1,5)_$S($L(IBDUEDAY)>1:IBDUEDAY,1:"0"_IBDUEDAY)
I PREVDUE>IBLDMP S PREVDUE=IBLDMP
S PLATEDT=$$FMADD^XLFDT(PREVDUE,IBLTDAY) ; calculate late date
;
; if current time greater than late date/time and creation time is less than due date/time, the file due
I IBNOW>IBLATEDT,IBCRDT<IBDUEDT S LATE=1
I IBCRDT<PREVDUE,IBNOW>PLATEDT S LATE=1
Q LATE ; file is not due.
;
MSGNORES(IBFILE) ; Notify G.IBCNF EII IRM mail group that the result file is not received
; input: IBNORES - result file name
; output: none
;
N XMSUB,IBMSG,XMY,XMTEXT,IBNOW,IBX
S XMSUB="Expected Result file has not been received."
S IBNOW=$$NOW^XLFDT()
S IBMSG(1)="Expected Result file "_IBFILE_" has not been received yet"
S XMTEXT="IBMSG("
S XMY("G.IBCNF EII IRM")=""
D ^XMD
Q
;
MSGNOEXT(IBNOEXT) ; Notify G.IBCNF EII IRM mail group that the extract file is not created
; input: IBNOEXT(<file name>)="" list of the extract file names.
; output: none
;
N XMSUB,IBMSG,XMY,XMTEXT,IBNOW,IBX,IBFILE
S XMSUB="Expected Extract files have not been created."
S IBNOW=$$NOW^XLFDT()
S IBMSG(1)="The following Extract file(s) have not been created yet:"
S IBFILE=""
S IBX=1
F S IBFILE=$O(IBNOEXT(IBFILE)) Q:IBFILE="" D
. S IBX=IBX+1
. S IBMSG(IBX)=" "_IBFILE
S XMTEXT="IBMSG("
S XMY("G.IBCNF EII IRM")=""
D ^XMD
Q
;
MSGNOTRC(IBNOTREC) ; Notify G.IBCNF EII IRM mail group the confirmation messages are not received for extract files
; input: IBNOTREC - array where
; IBNOTREC((<file index>)= <file name> ^
; IBNOTREC(<file index>, <message index>) = <message #> ^
; output: none
;
N XMSUB,IBRESMSG,XMY,XMTEXT,IBNOW,I,IBX,J
S XMSUB="Confirmation messages have not been received!!!"
S IBNOW=$$NOW^XLFDT()
S IBRESMSG(1)="Confirmation message(s) have not been received for the following file(s):"
S IBX=1
S I=0
F S I=$O(IBNOTREC(I)) Q:'I D
. S IBX=IBX+1
. S IBRESMSG(IBX)="File Name: "_$P(IBNOTREC(I),U)
. S J=0
. F S J=$O(IBNOTREC(I,J)) Q:'J D
. . S IBX=IBX+1
. . S IBRESMSG(IBX)=" Msg #: "_$P(IBNOTREC(I,J),U)
S XMTEXT="IBRESMSG("
S XMY("G.IBCNF EII IRM")=""
D ^XMD
Q
;
CHKEXT(IBD0,IBFILE,IBAITC,IBNOTREC) ; For given extract file type check if all messages are confirmed.
; input: IBD0 - ien of HMS extract file status (#355.35)
; IBFILE - file name
; IBAITC = AITC DMI queue email address.
;
; output: IBNOTREC array where
; IBNOTREC((<file index>)= file name^AITC DMI queue email address
; IBNOTREC(<file index>, <message index>) = message # ^ send date time
;
N IBD1,IBCONFRM,IBNOW,IBDIFF
S IBNOW=$$NOW^XLFDT()
S IBCONFRM=1
S IBD1=0
F S IBD1=$O(^IBA(355.35,IBD0,1,IBD1)) Q:'IBD1 D
. I $P($G(^IBA(355.35,IBD0,1,IBD1,0)),U,4)="" D ;if AITC confirmation number is empty
. . S IBCONFRM=0
. . S IBDIFF=$$HDIFF^XLFDT($$FMTH^XLFDT(IBNOW),$$FMTH^XLFDT($P($G(^IBA(355.35,IBD0,1,IBD1,0)),U,2)),2)
. . I IBDIFF>(IBCNFPAR(13.06)*3600) D ; if no confirmation received within due time
. . . S IBNOTREC(IBD0,IBD1)=$P($G(^IBA(355.35,IBD0,1,IBD1,0)),U)_U_$P($G(^IBA(355.35,IBD0,1,IBD1,0)),U,2)
. . . S IBNOTREC(IBD0)=IBFILE_U_IBAITC ; keep track of file name to be sent to IRM mail group
Q IBCONFRM
;
FILERD(DIR,FILE,IBTEXT) ; Read the extract file into @IBTEXT@ array
; input: DIR - HMS directory name
; FILE - extract file name
; output: IBTEXT - array name where file is read into as @IBTEXT@(<1...n>)
;
;
N IBI,IBREC,I
K @IBTEXT
; read the file
D OPEN^%ZISH("IBFILEX",DIR,FILE,"R")
Q:POP
U IO
S IBI=0
F Q:$$STATUS^%ZISH D
. R IBREC:5
. Q:$$STATUS^%ZISH
. S IBI=IBI+1
. S @IBTEXT@(IBI)=IBREC
D CLOSE^%ZISH("IBFILEX")
Q
;
MSGSEND(XMY,XMSUB,IBTEXT,IBFROM,IBTO,IBMAXREC) ; send the extract file text to AITC DMI Queue
; input: XMY - array of recipients names
; XMSUB - message subject
; IBTEXT - array name where content of message is read from @IBTEXT@(IBFROM:IBTO)
; IBFROM - start of the message text in @IBTEXT@() array
; IBTO - end of the message text in @IBTEXT@() array
; IBMAXREC - maximum line length that can be put into each messge line.
; output: returns the created message id
;
N XMDUZ,XMTEXT,TEMPTEXT,I,IBI,J,IBREC
S TEMPTEXT="TMP(""IBCNFSND_TEMP"",$J)"
K @TEMPTEXT
S IBI=0
F J=IBFROM:1:IBTO D
. S IBREC=@IBTEXT@(J)
. F I=1:IBMAXREC:$L(IBREC) D
. . S IBI=IBI+1
. . S @TEMPTEXT@(IBI)=$E(IBREC,I,IBMAXREC+I-1)
;
S @TEMPTEXT@(IBI+1)="NNNN" ; insert the end of message marker as required by AITC.
S XMTEXT=$E(TEMPTEXT,1,$L(TEMPTEXT)-1)_"," ;set XMTEXT in form of say "TMP(""IBCNFSND_TEMP"",$J,"
S XMDUZ=.5 ;post master (.5 user id)
; send the message
D ^XMD
K @TEMPTEXT
Q $G(XMZ)
;
CACTLOG(IBD0) ; create the activity log of HMS extract file status
; input: IBD0 - ien of HMS extract file status (#355.35)
; output: none
;
N IBCDT,IBD1,IBNODE,DA,DIC,X,Y
; create the the activity log subfile.
S IBCDT=$P(^IBA(355.35,IBD0,0),U,2)
S DA(1)=IBD0,DIC(0)="MLF",DLAYGO=355.35
S DIC="^IBA(355.35,"_DA(1)_",2,"
S X=IBCDT D FILE^DICN
; create messages subfile of activity log subfile
K DA,DIC,X
S DA(2)=IBD0
S DA(1)=+Y
S IBD1=0
F S IBD1=$O(^IBA(355.35,IBD0,1,IBD1)) Q:'IBD1 D
. S IBNODE=^IBA(355.35,IBD0,1,IBD1,0)
. S DIC(0)="MLF"
. S DIC="^IBA(355.35,"_DA(2)_",2,"_DA(1)_",1,"
. S DIC("DR")=".02///^S X=$P(IBNODE,U,2);.03///^S X=$P(IBNODE,U,3);.04///^S X=$P(IBNODE,U,4)"
. S X=$P(IBNODE,U)
. D FILE^DICN
Q
;
PURGELOG(IBAKEEP) ; purge the activity logs of HMS extract file status and HMS result file status
; input: IBAKEEP - number of days to keep the activity logs
; output: none
;
N IBCRDT,IBNOW,IBSTART,IBD0,DA,DIK
S IBNOW=$$NOW^XLFDT()
S IBSTART=$$HTFM^XLFDT($$HADD^XLFDT($$FMTH^XLFDT(IBNOW),-IBAKEEP))
;
; purge the HMS extract file status activity log.
S IBD0=0
F S IBD0=$O(^IBA(355.35,IBD0)) Q:'IBD0 D
. S IBCRDT=""
. F S IBCRDT=$O(^IBA(355.35,IBD0,2,"B",IBCRDT)) Q:'IBCRDT Q:IBCRDT>IBSTART D
. . ;W !, IBCRDT
. . S DA(1)=IBD0
. . S DA=$O(^IBA(355.35,IBD0,2,"B",IBCRDT,""))
. . S DIK="^IBA(355.35,"_DA(1)_",2,"
. . D ^DIK
;
; purge the HMS result file status activity log.
S IBD0=0
F S IBD0=$O(^IBA(355.351,IBD0)) Q:'IBD0 D
. S IBCRDT=""
. F S IBCRDT=$O(^IBA(355.351,IBD0,2,"B",IBCRDT)) Q:'IBCRDT Q:IBCRDT>IBSTART D
. . S DA(1)=IBD0
. . S DA=$O(^IBA(355.351,IBD0,2,"B",IBCRDT,""))
. . S DIK="^IBA(355.351,"_DA(1)_",2,"
. . D ^DIK
Q
;
RESNDMSG(IBNOTREC,IBAKEEP) ; Resend the messages for which the confirmation messages are not received for extract files
; input: IBNOTREC - array where
; IBNOTREC((<file index>)= file name^AITC DMI queue email address
; IBNOTREC(<file index>, <message index>) = message # ^ send date time
; IBAKEEP = number of days before purge the new message
; output: none
;
N XMSUB,IBRESMSG,XMY,XMTEXT,IBNOW,IBD0,IBD1,XMZ,IBRESEND,IBAITC,XMDUZ,XMPOS
S IBNOW=$$NOW^XLFDT()
S IBD0=0
; for each extract file type get the list of unconfirmed messages.
F S IBD0=$O(IBNOTREC(IBD0)) Q:'IBD0 D
. S IBAITC=$P(IBNOTREC(IBD0),U,2) ; AITC DMI Queue email address.
. S IBD1=0
. F S IBD1=$O(IBNOTREC(IBD0,IBD1)) Q:'IBD1 D
. . S IBXMZ=$P(IBNOTREC(IBD0,IBD1),U)
. . ; for this unconfirmed message, set AUSTIN ID and AITC Confirmation number to 0.
. . S DA=IBD1,DA(1)=IBD0
. . S DIE="^IBA(355.35,"_DA(1)_",1,"
. . S DR=".03///^S X=0;.04///^S X=0" D ^DIE
. . ;
. . ; get and resend the message, with the " - Re-Send:<old message id>"
. . ; appended to the subject of the new message.
. . D GMSGTXT(IBXMZ,.IBRESMSG)
. . S IBRESEND=" - Re-Send:"
. . S XMSUB=$$SUBGET^XMGAPI0(IBXMZ)
. . S XMSUB=$S(XMSUB[IBRESEND:$P(XMSUB,IBRESEND,1),1:XMSUB)_IBRESEND_IBXMZ
. . S XMY(IBAITC)="" ; AITC DMI queue address
. . S XMTEXT="IBRESMSG("
. . D ^XMD
. . ;
. . ; set the purge date for the message in message(#3.9) file
. . D VAPOR^XMXEDIT(XMZ,$$HTFM^XLFDT(+$H+IBAKEEP_","_$P($H,",",2)))
. . ;
. . ; record the time, the message is re-sent in HMS Extract File Status
. . K DIC S DA(1)=IBD0,DIC(0)="MLF",DLAYGO=355.35
. . S DIC="^IBA(355.35,"_DA(1)_",1,"
. . S DIC("DR")=".02///^S X=$$NOW^XLFDT()"
. . S X=XMZ
. . D FILE^DICN
Q
;
GMSGTXT(XMZ,IBRESMSG) ; get message's txt
; input: XMZ - message id.
; output: IBRESMSG - array containing the message's txt
;
N IBXMZ,XMER,XMA,XMRG
K IBRESMSG
S IBXMZ=$G(XMZ)
S XMA=0
F D Q:XMER<0
. D REC^XMS3 ; receive a line
. Q:XMER<0 ; check for end of message
. S XMA=XMA+1
. S IBRESMSG(XMA)=XMRG
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNFSND 16174 printed Oct 16, 2024@18:16:20 Page 2
IBCNFSND ;WOIFO/PO - Electronic Insurance Identification ;12/23/2011
+1 ;;2.0;INTEGRATED BILLING;**457**;21-MAR-94;Build 30
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;;
+4 ;
+5 ; Sending Extract files and checking status of file transfers.
+6 ;
+7 QUIT
+8 ;
SENDEII ; send HMS extract files and check status of files transfers.
+1 ; this subroutine is called from IBAMTC routine which is an scheduled job running once a day.
+2 ;
+3 NEW IBNOTREC,IBNOEXT,IBCNFPAR,IBCRDT,IBD0,IBD1,IBEXTNOD,IBFARR,IBFILE,IBFLIST,IBFROM,IBFSPEC,IBMSGNUM,IBNOEXT
+4 NEW IBNUMMSG,IBNUMREC,IBPSTDUE,IBSUB1,IBTEXT,IBTO,IBXMSUB,IBXMY,IBNORES,IBMAXREC,IBAKEEP,IBXMZ
+5 NEW X,Y,DA,DIC,DIK,D0,D1,D2,DG,DI,DIW,DICR,DIE,DLAYGO,DQ,DR,XMDUN,XMZ,IBFILEX,FNDFILE,FNDFILES
+6 ; get the IB configuration parameters and list of active extract files.
+7 DO GETPARAM^IBCNFRD(.IBCNFPAR)
+8 ;
+9 ; if eII active field is not 1 quit.
IF 'IBCNFPAR(13.02)
QUIT
+10 ;
+11 ; message's maximum record line legth
SET IBMAXREC=255
+12 ; number of days to keep the activity logs before get purged.
SET IBAKEEP=6*30
+13 ; @IBTEXT@(1:nnn) array to store the extract file content.
SET IBTEXT="^TMP(""IBCNFCND_IBTEXT"",$J)"
+14 KILL @IBTEXT
+15 ;
+16 ; for each active extracted HMS file name.
+17 SET IBSUB1=0
+18 FOR
SET IBSUB1=$ORDER(IBCNFPAR(13.08,IBSUB1))
if 'IBSUB1
QUIT
Begin DoDot:1
+19 SET IBEXTNOD=IBCNFPAR(13.08,IBSUB1)
+20 ; extract file name
SET IBFILE=$PIECE(IBEXTNOD,U,3)
+21 ;
+22 KILL DIC
SET DIC="^IBA(355.35,"
SET DIC(0)="QZL"
SET X=$PIECE(IBEXTNOD,U,1)
DO ^DIC
+23 SET IBD0=+Y
+24 ;creation date time.
SET IBCRDT=$PIECE(Y(0),U,2)
+25 ; first time this type is created.
IF 'IBCRDT
SET IBCRDT=$$NOW^XLFDT()
+26 ;
+27 ; Check message sub-file for all acknowledgements
+28 ; want to do this first, so we can get the old ones cleared out
+29 ; and put in activity log
+30 ;
+31 IF $ORDER(^IBA(355.35,IBD0,1,0))
Begin DoDot:2
+32 ; if confirmation messages are received for the extract file
+33 IF $$CHKEXT(IBD0,IBFILE,$PIECE(IBEXTNOD,U,4),.IBNOTREC)
Begin DoDot:3
+34 ; save the top-level fields of HMS extract file status in the activity log sub-file.
DO CACTLOG(IBD0)
+35 ; kill the messages sub-file.
+36 SET DA(1)=IBD0
SET DA=0
+37 SET DIK="^IBA(355.35,"_DA(1)_",1,"
+38 FOR
SET DA=$ORDER(^IBA(355.35,IBD0,1,DA))
if 'DA
QUIT
DO ^DIK
End DoDot:3
End DoDot:2
+39 ;
+40 ; check, if the extract file exits.
+41 KILL IBFSPEC,IBFLIST,FNDFILES
+42 SET IBFSPEC(IBFILE)=""
+43 ;process all the versions of files
+44 FOR
KILL IBFLIST
SET FNDFILE=$$LIST^%ZISH(IBCNFPAR(13.01),"IBFSPEC","IBFLIST")
if 'FNDFILE
QUIT
Begin DoDot:2
+45 SET FNDFILES(IBFILE)=""
+46 ;Get the full name of the first file found (includes version number for VMS based systems)
+47 SET IBFILEX=$ORDER(IBFLIST(""))
+48 ;
+49 ; set the file creation date/time.
+50 SET DIE="^IBA(355.35,"
SET DA=IBD0
SET DR=".02///^S X=$$NOW^XLFDT()"
DO ^DIE
+51 ;
+52 ; open the eII file and read the content into @IBTEXT@ global and cut the
+53 ; records to 255 (IBMAXREC) character chunks if more than 255 (IBMAXREC) characters.
+54 DO FILERD(IBCNFPAR(13.01),IBFILEX,IBTEXT)
+55 ;
+56 ; build the file message(s)with the maximum number of lines per message.
+57 ; and send the file message(s) to related AITC queue.
+58 ; number of records
SET IBNUMREC=$ORDER(@IBTEXT@(""),-1)
+59 ; number of message to be sent
SET IBNUMMSG=IBNUMREC\IBCNFPAR(13.07)
+60 ; add one message if number records is not multiple of max number of records
if IBNUMREC#IBCNFPAR(13.07)
SET IBNUMMSG=IBNUMMSG+1
+61 ; make sure at least one message is sent if the extract file is empty
if IBNUMMSG<1
SET IBNUMMSG=1
+62 FOR IBMSGNUM=1:1:IBNUMMSG
Begin DoDot:3
+63 SET IBFROM=((IBMSGNUM-1)*IBCNFPAR(13.07)+1)
+64 SET IBTO=IBMSGNUM*IBCNFPAR(13.07)
+65 if IBTO>IBNUMREC
SET IBTO=IBNUMREC
+66 SET IBXMSUB="HMS eII Extracted file "_IBFILE_" MSG("_IBMSGNUM_"/"_IBNUMMSG_")"
+67 ; send it to associated ATIC queue address e.g. XXX@Q-IBN.DOMAIN.EXT
SET IBXMY($PIECE(IBEXTNOD,U,4))=""
+68 SET IBXMZ=$$MSGSEND(.IBXMY,IBXMSUB,IBTEXT,IBFROM,IBTO,IBMAXREC)
+69 ;
+70 ; set the purge date for the message in message(#3.9) file
+71 DO VAPOR^XMXEDIT(IBXMZ,$$HTFM^XLFDT(+$HOROLOG+IBAKEEP_","_$PIECE($HOROLOG,",",2)))
+72 ;
+73 ; record the creation date/time and the time the message(s) were sent in HMS Extract File Status
+74 KILL DIC
SET DA(1)=IBD0
SET DIC(0)="MLF"
SET DLAYGO=355.35
+75 SET DIC="^IBA(355.35,"_DA(1)_",1,"
+76 SET DIC("DR")=".02///^S X=$$NOW^XLFDT()"
+77 SET X=IBXMZ
+78 DO FILE^DICN
End DoDot:3
+79 ; delete the file using its full name
+80 SET IBFARR(IBFILEX)=""
+81 SET Y=$$DEL^%ZISH(IBCNFPAR(13.01),$NAME(IBFARR))
End DoDot:2
+82 ;
+83 ;else if extracted file does not exist, save the file name to be reported.
IF '$DATA(FNDFILES(IBFILE))
Begin DoDot:2
+84 SET IBPSTDUE=$$FILEDUE^IBCNFSND($PIECE(IBEXTNOD,U,5),$PIECE(IBEXTNOD,U,6),IBCRDT)
+85 if IBPSTDUE
SET IBNOEXT(IBFILE)=""
End DoDot:2
End DoDot:1
+86 ;
+87 ; send an email to IBCNF EII IRM mail group with list of files and messages that their
+88 ; confirmation messages are not received within the given time. then re-send the message to ATIC.
+89 IF $DATA(IBNOTREC)>0
Begin DoDot:1
+90 DO MSGNOTRC^IBCNFSND(.IBNOTREC)
+91 DO RESNDMSG(.IBNOTREC,IBAKEEP)
End DoDot:1
+92 ;
+93 ; if extract files are not created withing the give time send an email to IBCNF EII IRM mail group.
+94 IF $DATA(IBNOEXT)>0
DO MSGNOEXT^IBCNFSND(.IBNOEXT)
+95 ;
+96 ; if a Result File is not received within the due time
+97 ; Send an email to IBCNF EII IRM mail group
+98 SET IBCRDT=+$PIECE($GET(^IBA(355.351,1,0)),U,2)
+99 SET IBPSTDUE=$$FILEDUE^IBCNFSND(IBCNFPAR(13.04),IBCNFPAR(13.05),IBCRDT)
+100 IF IBPSTDUE>0
DO MSGNORES^IBCNFSND(IBCNFPAR(13.03))
+101 ;
+102 ; purge the entries older than 6 months in Activity Log sub-file of
+103 ; HMS Extract File Status and HMS Result File Status
+104 ; purge the activity logs of HMS extract file status and HMS result file status
DO PURGELOG(IBAKEEP)
+105 ;
+106 KILL @IBTEXT
+107 ;
+108 QUIT
+109 ;
FILEDUE(IBDUEDAY,IBLTDAY,IBCRDT,IBNOW) ; check if file is due
+1 ; input: IBDEUDAY - day of the month the file is due
+2 ; IBLTDAY - number of days after day of month to declare file is late
+3 ; IBCRDT - date/time last file was processed
+4 ; output: 1 - if file is due
+5 ; 0 - if file is not due
+6 ;
+7 NEW IBLDM,IBDUEDT,IBLATEDT,LATE,PREVDUE,IBFDOM,IBPFDOM,PLATEDT
+8 SET IBNOW=$GET(IBNOW,$$NOW^XLFDT())
+9 SET LATE=0
+10 ; if day of month file due day is 0 retrun 0, since this is as needed file.
+11 ; do not check assume not past due.
IF 'IBDUEDAY
QUIT LATE
+12 ; current date
SET IBNOW=IBNOW\1
+13 SET IBCRDT=IBCRDT\1
+14 ;
+15 ; calculate the due date and passed due late date.
+16 ; last day of month
SET IBLDM=$EXTRACT($$SCH^XLFDT("1M(L@1A)",IBNOW)\1,6,7)
+17 ; if due day greater than last day of currnt month set it to last date of current month.
IF IBDUEDAY>IBLDM
SET IBDUEDAY=IBLDM
+18 SET IBDUEDT=$EXTRACT(IBNOW,1,5)_$SELECT($LENGTH(IBDUEDAY)>1:IBDUEDAY,1:"0"_IBDUEDAY)
+19 ; calculate late date
SET IBLATEDT=$$FMADD^XLFDT(IBDUEDT,IBLTDAY)
+20 ;FIRST OF THIS MONTH
+21 SET IBFDOM=$EXTRACT(IBNOW,1,5)_"01"
+22 ;MINUS ONE GETS LAST DAY OF PREVIOUS MONTH
+23 SET IBLDMP=$$HTFM^XLFDT($$FMTH^XLFDT(IBFDOM,1)-1,1)
+24 ; SETUP FIRST DAY OF PREV MONTH TO CALCULATE DUE DATE OF PREV MONTH
+25 SET IBPFDOM=$EXTRACT(IBLDMP,1,5)_"01"
+26 ;NOW CALCULATE DUE DATE OF PREV MONTH
+27 SET PREVDUE=$EXTRACT(IBPFDOM,1,5)_$SELECT($LENGTH(IBDUEDAY)>1:IBDUEDAY,1:"0"_IBDUEDAY)
+28 IF PREVDUE>IBLDMP
SET PREVDUE=IBLDMP
+29 ; calculate late date
SET PLATEDT=$$FMADD^XLFDT(PREVDUE,IBLTDAY)
+30 ;
+31 ; if current time greater than late date/time and creation time is less than due date/time, the file due
+32 IF IBNOW>IBLATEDT
IF IBCRDT<IBDUEDT
SET LATE=1
+33 IF IBCRDT<PREVDUE
IF IBNOW>PLATEDT
SET LATE=1
+34 ; file is not due.
QUIT LATE
+35 ;
MSGNORES(IBFILE) ; Notify G.IBCNF EII IRM mail group that the result file is not received
+1 ; input: IBNORES - result file name
+2 ; output: none
+3 ;
+4 NEW XMSUB,IBMSG,XMY,XMTEXT,IBNOW,IBX
+5 SET XMSUB="Expected Result file has not been received."
+6 SET IBNOW=$$NOW^XLFDT()
+7 SET IBMSG(1)="Expected Result file "_IBFILE_" has not been received yet"
+8 SET XMTEXT="IBMSG("
+9 SET XMY("G.IBCNF EII IRM")=""
+10 DO ^XMD
+11 QUIT
+12 ;
MSGNOEXT(IBNOEXT) ; Notify G.IBCNF EII IRM mail group that the extract file is not created
+1 ; input: IBNOEXT(<file name>)="" list of the extract file names.
+2 ; output: none
+3 ;
+4 NEW XMSUB,IBMSG,XMY,XMTEXT,IBNOW,IBX,IBFILE
+5 SET XMSUB="Expected Extract files have not been created."
+6 SET IBNOW=$$NOW^XLFDT()
+7 SET IBMSG(1)="The following Extract file(s) have not been created yet:"
+8 SET IBFILE=""
+9 SET IBX=1
+10 FOR
SET IBFILE=$ORDER(IBNOEXT(IBFILE))
if IBFILE=""
QUIT
Begin DoDot:1
+11 SET IBX=IBX+1
+12 SET IBMSG(IBX)=" "_IBFILE
End DoDot:1
+13 SET XMTEXT="IBMSG("
+14 SET XMY("G.IBCNF EII IRM")=""
+15 DO ^XMD
+16 QUIT
+17 ;
MSGNOTRC(IBNOTREC) ; Notify G.IBCNF EII IRM mail group the confirmation messages are not received for extract files
+1 ; input: IBNOTREC - array where
+2 ; IBNOTREC((<file index>)= <file name> ^
+3 ; IBNOTREC(<file index>, <message index>) = <message #> ^
+4 ; output: none
+5 ;
+6 NEW XMSUB,IBRESMSG,XMY,XMTEXT,IBNOW,I,IBX,J
+7 SET XMSUB="Confirmation messages have not been received!!!"
+8 SET IBNOW=$$NOW^XLFDT()
+9 SET IBRESMSG(1)="Confirmation message(s) have not been received for the following file(s):"
+10 SET IBX=1
+11 SET I=0
+12 FOR
SET I=$ORDER(IBNOTREC(I))
if 'I
QUIT
Begin DoDot:1
+13 SET IBX=IBX+1
+14 SET IBRESMSG(IBX)="File Name: "_$PIECE(IBNOTREC(I),U)
+15 SET J=0
+16 FOR
SET J=$ORDER(IBNOTREC(I,J))
if 'J
QUIT
Begin DoDot:2
+17 SET IBX=IBX+1
+18 SET IBRESMSG(IBX)=" Msg #: "_$PIECE(IBNOTREC(I,J),U)
End DoDot:2
End DoDot:1
+19 SET XMTEXT="IBRESMSG("
+20 SET XMY("G.IBCNF EII IRM")=""
+21 DO ^XMD
+22 QUIT
+23 ;
CHKEXT(IBD0,IBFILE,IBAITC,IBNOTREC) ; For given extract file type check if all messages are confirmed.
+1 ; input: IBD0 - ien of HMS extract file status (#355.35)
+2 ; IBFILE - file name
+3 ; IBAITC = AITC DMI queue email address.
+4 ;
+5 ; output: IBNOTREC array where
+6 ; IBNOTREC((<file index>)= file name^AITC DMI queue email address
+7 ; IBNOTREC(<file index>, <message index>) = message # ^ send date time
+8 ;
+9 NEW IBD1,IBCONFRM,IBNOW,IBDIFF
+10 SET IBNOW=$$NOW^XLFDT()
+11 SET IBCONFRM=1
+12 SET IBD1=0
+13 FOR
SET IBD1=$ORDER(^IBA(355.35,IBD0,1,IBD1))
if 'IBD1
QUIT
Begin DoDot:1
+14 ;if AITC confirmation number is empty
IF $PIECE($GET(^IBA(355.35,IBD0,1,IBD1,0)),U,4)=""
Begin DoDot:2
+15 SET IBCONFRM=0
+16 SET IBDIFF=$$HDIFF^XLFDT($$FMTH^XLFDT(IBNOW),$$FMTH^XLFDT($PIECE($GET(^IBA(355.35,IBD0,1,IBD1,0)),U,2)),2)
+17 ; if no confirmation received within due time
IF IBDIFF>(IBCNFPAR(13.06)*3600)
Begin DoDot:3
+18 SET IBNOTREC(IBD0,IBD1)=$PIECE($GET(^IBA(355.35,IBD0,1,IBD1,0)),U)_U_$PIECE($GET(^IBA(355.35,IBD0,1,IBD1,0)),U,2)
+19 ; keep track of file name to be sent to IRM mail group
SET IBNOTREC(IBD0)=IBFILE_U_IBAITC
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT IBCONFRM
+21 ;
FILERD(DIR,FILE,IBTEXT) ; Read the extract file into @IBTEXT@ array
+1 ; input: DIR - HMS directory name
+2 ; FILE - extract file name
+3 ; output: IBTEXT - array name where file is read into as @IBTEXT@(<1...n>)
+4 ;
+5 ;
+6 NEW IBI,IBREC,I
+7 KILL @IBTEXT
+8 ; read the file
+9 DO OPEN^%ZISH("IBFILEX",DIR,FILE,"R")
+10 if POP
QUIT
+11 USE IO
+12 SET IBI=0
+13 FOR
if $$STATUS^%ZISH
QUIT
Begin DoDot:1
+14 READ IBREC:5
+15 if $$STATUS^%ZISH
QUIT
+16 SET IBI=IBI+1
+17 SET @IBTEXT@(IBI)=IBREC
End DoDot:1
+18 DO CLOSE^%ZISH("IBFILEX")
+19 QUIT
+20 ;
MSGSEND(XMY,XMSUB,IBTEXT,IBFROM,IBTO,IBMAXREC) ; send the extract file text to AITC DMI Queue
+1 ; input: XMY - array of recipients names
+2 ; XMSUB - message subject
+3 ; IBTEXT - array name where content of message is read from @IBTEXT@(IBFROM:IBTO)
+4 ; IBFROM - start of the message text in @IBTEXT@() array
+5 ; IBTO - end of the message text in @IBTEXT@() array
+6 ; IBMAXREC - maximum line length that can be put into each messge line.
+7 ; output: returns the created message id
+8 ;
+9 NEW XMDUZ,XMTEXT,TEMPTEXT,I,IBI,J,IBREC
+10 SET TEMPTEXT="TMP(""IBCNFSND_TEMP"",$J)"
+11 KILL @TEMPTEXT
+12 SET IBI=0
+13 FOR J=IBFROM:1:IBTO
Begin DoDot:1
+14 SET IBREC=@IBTEXT@(J)
+15 FOR I=1:IBMAXREC:$LENGTH(IBREC)
Begin DoDot:2
+16 SET IBI=IBI+1
+17 SET @TEMPTEXT@(IBI)=$EXTRACT(IBREC,I,IBMAXREC+I-1)
End DoDot:2
End DoDot:1
+18 ;
+19 ; insert the end of message marker as required by AITC.
SET @TEMPTEXT@(IBI+1)="NNNN"
+20 ;set XMTEXT in form of say "TMP(""IBCNFSND_TEMP"",$J,"
SET XMTEXT=$EXTRACT(TEMPTEXT,1,$LENGTH(TEMPTEXT)-1)_","
+21 ;post master (.5 user id)
SET XMDUZ=.5
+22 ; send the message
+23 DO ^XMD
+24 KILL @TEMPTEXT
+25 QUIT $GET(XMZ)
+26 ;
CACTLOG(IBD0) ; create the activity log of HMS extract file status
+1 ; input: IBD0 - ien of HMS extract file status (#355.35)
+2 ; output: none
+3 ;
+4 NEW IBCDT,IBD1,IBNODE,DA,DIC,X,Y
+5 ; create the the activity log subfile.
+6 SET IBCDT=$PIECE(^IBA(355.35,IBD0,0),U,2)
+7 SET DA(1)=IBD0
SET DIC(0)="MLF"
SET DLAYGO=355.35
+8 SET DIC="^IBA(355.35,"_DA(1)_",2,"
+9 SET X=IBCDT
DO FILE^DICN
+10 ; create messages subfile of activity log subfile
+11 KILL DA,DIC,X
+12 SET DA(2)=IBD0
+13 SET DA(1)=+Y
+14 SET IBD1=0
+15 FOR
SET IBD1=$ORDER(^IBA(355.35,IBD0,1,IBD1))
if 'IBD1
QUIT
Begin DoDot:1
+16 SET IBNODE=^IBA(355.35,IBD0,1,IBD1,0)
+17 SET DIC(0)="MLF"
+18 SET DIC="^IBA(355.35,"_DA(2)_",2,"_DA(1)_",1,"
+19 SET DIC("DR")=".02///^S X=$P(IBNODE,U,2);.03///^S X=$P(IBNODE,U,3);.04///^S X=$P(IBNODE,U,4)"
+20 SET X=$PIECE(IBNODE,U)
+21 DO FILE^DICN
End DoDot:1
+22 QUIT
+23 ;
PURGELOG(IBAKEEP) ; purge the activity logs of HMS extract file status and HMS result file status
+1 ; input: IBAKEEP - number of days to keep the activity logs
+2 ; output: none
+3 ;
+4 NEW IBCRDT,IBNOW,IBSTART,IBD0,DA,DIK
+5 SET IBNOW=$$NOW^XLFDT()
+6 SET IBSTART=$$HTFM^XLFDT($$HADD^XLFDT($$FMTH^XLFDT(IBNOW),-IBAKEEP))
+7 ;
+8 ; purge the HMS extract file status activity log.
+9 SET IBD0=0
+10 FOR
SET IBD0=$ORDER(^IBA(355.35,IBD0))
if 'IBD0
QUIT
Begin DoDot:1
+11 SET IBCRDT=""
+12 FOR
SET IBCRDT=$ORDER(^IBA(355.35,IBD0,2,"B",IBCRDT))
if 'IBCRDT
QUIT
if IBCRDT>IBSTART
QUIT
Begin DoDot:2
+13 ;W !, IBCRDT
+14 SET DA(1)=IBD0
+15 SET DA=$ORDER(^IBA(355.35,IBD0,2,"B",IBCRDT,""))
+16 SET DIK="^IBA(355.35,"_DA(1)_",2,"
+17 DO ^DIK
End DoDot:2
End DoDot:1
+18 ;
+19 ; purge the HMS result file status activity log.
+20 SET IBD0=0
+21 FOR
SET IBD0=$ORDER(^IBA(355.351,IBD0))
if 'IBD0
QUIT
Begin DoDot:1
+22 SET IBCRDT=""
+23 FOR
SET IBCRDT=$ORDER(^IBA(355.351,IBD0,2,"B",IBCRDT))
if 'IBCRDT
QUIT
if IBCRDT>IBSTART
QUIT
Begin DoDot:2
+24 SET DA(1)=IBD0
+25 SET DA=$ORDER(^IBA(355.351,IBD0,2,"B",IBCRDT,""))
+26 SET DIK="^IBA(355.351,"_DA(1)_",2,"
+27 DO ^DIK
End DoDot:2
End DoDot:1
+28 QUIT
+29 ;
RESNDMSG(IBNOTREC,IBAKEEP) ; Resend the messages for which the confirmation messages are not received for extract files
+1 ; input: IBNOTREC - array where
+2 ; IBNOTREC((<file index>)= file name^AITC DMI queue email address
+3 ; IBNOTREC(<file index>, <message index>) = message # ^ send date time
+4 ; IBAKEEP = number of days before purge the new message
+5 ; output: none
+6 ;
+7 NEW XMSUB,IBRESMSG,XMY,XMTEXT,IBNOW,IBD0,IBD1,XMZ,IBRESEND,IBAITC,XMDUZ,XMPOS
+8 SET IBNOW=$$NOW^XLFDT()
+9 SET IBD0=0
+10 ; for each extract file type get the list of unconfirmed messages.
+11 FOR
SET IBD0=$ORDER(IBNOTREC(IBD0))
if 'IBD0
QUIT
Begin DoDot:1
+12 ; AITC DMI Queue email address.
SET IBAITC=$PIECE(IBNOTREC(IBD0),U,2)
+13 SET IBD1=0
+14 FOR
SET IBD1=$ORDER(IBNOTREC(IBD0,IBD1))
if 'IBD1
QUIT
Begin DoDot:2
+15 SET IBXMZ=$PIECE(IBNOTREC(IBD0,IBD1),U)
+16 ; for this unconfirmed message, set AUSTIN ID and AITC Confirmation number to 0.
+17 SET DA=IBD1
SET DA(1)=IBD0
+18 SET DIE="^IBA(355.35,"_DA(1)_",1,"
+19 SET DR=".03///^S X=0;.04///^S X=0"
DO ^DIE
+20 ;
+21 ; get and resend the message, with the " - Re-Send:<old message id>"
+22 ; appended to the subject of the new message.
+23 DO GMSGTXT(IBXMZ,.IBRESMSG)
+24 SET IBRESEND=" - Re-Send:"
+25 SET XMSUB=$$SUBGET^XMGAPI0(IBXMZ)
+26 SET XMSUB=$SELECT(XMSUB[IBRESEND:$PIECE(XMSUB,IBRESEND,1),1:XMSUB)_IBRESEND_IBXMZ
+27 ; AITC DMI queue address
SET XMY(IBAITC)=""
+28 SET XMTEXT="IBRESMSG("
+29 DO ^XMD
+30 ;
+31 ; set the purge date for the message in message(#3.9) file
+32 DO VAPOR^XMXEDIT(XMZ,$$HTFM^XLFDT(+$HOROLOG+IBAKEEP_","_$PIECE($HOROLOG,",",2)))
+33 ;
+34 ; record the time, the message is re-sent in HMS Extract File Status
+35 KILL DIC
SET DA(1)=IBD0
SET DIC(0)="MLF"
SET DLAYGO=355.35
+36 SET DIC="^IBA(355.35,"_DA(1)_",1,"
+37 SET DIC("DR")=".02///^S X=$$NOW^XLFDT()"
+38 SET X=XMZ
+39 DO FILE^DICN
End DoDot:2
End DoDot:1
+40 QUIT
+41 ;
GMSGTXT(XMZ,IBRESMSG) ; get message's txt
+1 ; input: XMZ - message id.
+2 ; output: IBRESMSG - array containing the message's txt
+3 ;
+4 NEW IBXMZ,XMER,XMA,XMRG
+5 KILL IBRESMSG
+6 SET IBXMZ=$GET(XMZ)
+7 SET XMA=0
+8 FOR
Begin DoDot:1
+9 ; receive a line
DO REC^XMS3
+10 ; check for end of message
if XMER<0
QUIT
+11 SET XMA=XMA+1
+12 SET IBRESMSG(XMA)=XMRG
End DoDot:1
if XMER<0
QUIT
+13 QUIT
+14 ;
