- 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 Jan 18, 2025@03:16:53 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 ;