- RCRCSRV ;ALB/CMS - RC SERVER DRIVER ; 16-JUN-00
- V ;;4.5;Accounts Receivable;**61,87,63,147,159**;Mar 20, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- SERVER ;RC RC SERV SERVER OPTION MAIN ENTRY POINT
- ;INPUT : Mailman variables
- ;OUTPUT : Sets the XTMP global for certain types of message
- ; : Sets the task job in the background if appropriate
- ; : Adds Confirmation or Error to AR Transmission File
- ;
- Q:$G(XMZ)="" Q:'$D(^XMB(3.9,XMZ))
- S XMXX="S.RC RC SERV",XMCHAN=1
- D SETSB^XMA1C ;Save message in postmaster server basket
- N RCBDT,RCCMSG,RCDOM,RCEDT,RCJOB,RCSCE,RCSTA,RCTYP,RCVAR,RCSITE,RCXMY,RCXMZ,RCXTYP
- S RCXMZ=XMZ,RCJOB=$J
- D READ
- D SEND
- D TASK
- S XMZ=RCXMZ,XMSER="S.RC RC SERV" D REMSBMSG^XMA1C
- K XMCHAN,XMDUZ,XMDUN,XMFROM,XMREC,XMSER,XMXX,XMY,XMZ
- Q Q
- ;
- READ ;READ TRANSMISSION CHK FIRST LINE PUT MESSAGE IN XTMP
- N II,RCEND,RCNT,XMRG,XMER,X2
- S RCNT=0,RCCMSG="",RCSITE=$$SITE^RCMSITE,RCDOM=$G(XMFROM)
- F II=0:0 D Q:$G(RCCMSG)]""
- .X XMREC S RCNT=RCNT+1
- .I $G(XMER)<0 D Q
- ..I $G(RCEND)="" S RCCMSG="E;Incomplete message from Regional Counsel"
- ..E S RCCMSG="C;AR accepted "_RCNT_" lines successfully."
- ..S RCBDT=$P($G(RCEND),"$",4),RCEDT=$P($G(RCEND),"$",5)
- ..; I +$P(RCVAR,U,5),$D(^XTMP(RCXTYP,RCJOB,0)) S $P(^XTMP(RCXTYP,RCJOB,0),"^",5)=RCNT
- .I RCNT=1 D CHK1 I $G(RCCMSG)]"" Q
- .I ($P(XMRG,"$",2)="END")!($P(XMRG,"$",3)="END") S RCEND=XMRG S RCNT=RCNT-1 Q
- .I '$L(XMRG) S RCNT=RCNT-1 Q
- .I +$P(RCVAR,U,5) S ^XTMP(RCXTYP,RCXMZ,RCNT)=XMRG
- Q
- ;
- SEND ;CONFIRMATION, ERROR, ORIGINAL MESSAGE TRANSPORT
- ;I message is the original send confirmation or error to RC
- ;INPUT: RCCMSG from Read module always set
- ; RCVAR if exists
- ;I message is a Confirmation or Error from RC to site quit
- I $P(RCCMSG,";",1)="Q" G SENDQ
- S RETRY=0
- ;
- XMB N LN,RCCOM,RCSUB,RCWHO,RETRY,XMDUZ,XMSUB,XMTEXT,XMY,X,Y
- ;Line below may not be needed
- ;I confirmation don't send to anyone.
- I $G(RCDOM)="" S RCDOM=$$RCDOM^RCRCUTL
- S:$G(XMFROM)]"" XMY(XMFROM)=""
- ;S RCWHO="S.RC RC SERV@"_RCDOM,XMY(RCWHO)=""
- S RCWHO=RCDOM,XMY(RCWHO)=""
- S Y=DT D D^DIQ
- S LN(1)="$$RC$"_$G(RCTYP,"UNK")_"$"_$E(RCCMSG,1)_"$"_$G(RCSITE,"UNK")_"$"
- S LN(2)="Status: Mail Message #("_XMZ_") received at the VAMC "_$G(RCSITE,"UNK")_" system on "_Y
- S LN(3)=$S($E(RCCMSG,1)="E":"Error ",1:"")_"Message: "_$P(RCCMSG,";",2)
- S LN(4)="Desc.: "_$P($G(RCVAR),U,4)
- S (RCSUB,XMSUB)="AR/RC - "_$G(RCSITE,"UNK")_" "_$S($E(RCCMSG,1)="C":"CONFIRMATION ("_$G(RCTYP,"UNK")_")",1:"TRANSMISSION ("_$G(RCTYP,"UNK")_") ERROR")_" MESSAGE"
- S XMTEXT="LN(",XMDUZ="ACCOUNTS RECEIVABLE RC SERVER"
- D ^XMD I XMZ<1 S RETRY=RETRY+1 I RETRY<100 G XMB
- S RCCOM=LN(3)
- D ENT^RCRCXMS(XMZ,RCSUB,RCWHO,RCCOM)
- SENDQ Q
- ;
- CHK1 ;CHECK FIRST LINE OF TRANSMISSION
- ;First Line Syntax:
- ;$$RC$S1$$sta#prefix$RC Address
- ; o first four characters must be $$RC$
- ; o $ piece 4 required must be a server code in routine RCRCVAR
- ; o $ piece 5 will be "C" for a confirmation message or
- ; "E" for error receiving the message
- ; "" for the original transmission of a message
- ; o $ piece 6 station number
- ; o $ piece 7 is the RC address to send back to at RCDOM
- ;Last Line Syntax: $END$#oflines$
- ; $END$#oflines$Beg.Ref.DT$End.Ref.DT (Rec Rept. 4 of 4)
- ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- ;INPUT: XMRG - First line of mail message
- ;OUTPUT: RCVAR - Server Code^(C,E,O)^Recipient^desc.^0or1^taskroutine
- ; or Killed
- ; RCCMSG - Error message
- ; RCSTA - Station Number
- ; RCXMY - send message to
- ; RCJOB - $J
- ;
- I $E(XMRG,1,5)'="$$RC$" S RCCMSG="E;RC Server at site is unable to interpret the first line of this message." G CHK1Q
- S RCSCE=$P(XMRG,"$",5) S RCSCE=$S(RCSCE="C":RCSCE,RCSCE="E":RCSCE,RCSCE="":"O",1:"UNK")
- S RCTYP=$P(XMRG,"$",4),RCVAR=$$CHK^RCRCVAR(RCTYP,RCSCE)
- I $P(RCVAR,";",1)="E" S RCCMSG=RCVAR K RCVAR G CHK1Q
- S RCSTA=$P(XMRG,"$",6)
- S RCXMY=$P(XMRG,"$",7)
- S RCDOM=$G(XMFROM)
- ; If original message needs an XTMP global initialize it
- I +$P(RCVAR,U,5) D XTMP(RCTYP,$P(RCVAR,U,4))
- D FILE
- I "CE"[RCSCE S RCCMSG="Q;"
- CHK1Q Q
- ;
- TASK ;If message is original fire off the background job
- ;fire off the background task now. (The time the server is run.)
- I $G(RCSCE)="O",$E($G(RCCMSG),1)'="E" D TASK^RCRCRR
- TASKQ Q
- ;
- FILE ;Update AR Transmission File
- N DA,DIE,DR,RCCOM,RCX,X,Y
- I RCSCE="O" D G FILEQ
- . S RCSUB=$$SUBGET^XMGAPI0(RCXMZ)
- . S RCCOM="RC sent Request Action ("_RCTYP_")."
- . D ENT^RCRCXMS(RCXMZ,$G(RCSUB),"RC SERVER AT "_RCSTA,RCCOM)
- ;If Message is a Confirm or Error from RC
- X XMREC S RCNT=RCNT+1 I XMRG'["STATUS:" G FILEQ
- S RCX=+$P(XMRG,"Message ",2)
- S DA=$O(^RCT(349.3,"B",RCX,0))
- I DA S DIE="^RCT(349.3,",DR=$S(RCSCE="E":6,1:5)_"////^S X="_RCXMZ D ^DIE
- I 'DA,RCSCE="E" D
- . S RCSUB=$$SUBGET^XMGAPI0(RCXMZ)
- . S RCCOM="RC sent Error message ("_RCTYP_")."
- . D ENT^RCRCXMS(RCXMZ,$G(RCSUB),"RC SERVER AT "_RCSTA,RCCOM)
- FILEQ Q
- ;
- XTMP(RCTYP,RCDSC) ;INITIALIZE TOP XTMP Global for Server Type
- ;INPUT : Type of server message must be passed
- ;OUTPUT: XTMP global gets created for this server type
- ; : RCXTYP gets set to PRCA_rctype(MR1,RR1,TR,CL...)
- ; : RCJOB Job Number
- ;XTMP purge data will be 30 days past the create date
- N RCDT,X,X1,X2,Y,%,%H,%I
- D NOW^%DTC S (X1,RCDT)=X,X2=30 D C^%DTC
- S RCXTYP="PRCA"_RCTYP K ^XTMP(RCXTYP,RCXMZ)
- S ^XTMP(RCXTYP,RCXMZ,0)=X_"^"_RCDT_"^"_RCDSC_U_RCXMZ
- Q
- ;RCRCSRV
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRCSRV 5635 printed Feb 18, 2025@23:14:11 Page 2
- RCRCSRV ;ALB/CMS - RC SERVER DRIVER ; 16-JUN-00
- V ;;4.5;Accounts Receivable;**61,87,63,147,159**;Mar 20, 1995
- +1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- SERVER ;RC RC SERV SERVER OPTION MAIN ENTRY POINT
- +1 ;INPUT : Mailman variables
- +2 ;OUTPUT : Sets the XTMP global for certain types of message
- +3 ; : Sets the task job in the background if appropriate
- +4 ; : Adds Confirmation or Error to AR Transmission File
- +5 ;
- +6 if $GET(XMZ)=""
- QUIT
- if '$DATA(^XMB(3.9,XMZ))
- QUIT
- +7 SET XMXX="S.RC RC SERV"
- SET XMCHAN=1
- +8 ;Save message in postmaster server basket
- DO SETSB^XMA1C
- +9 NEW RCBDT,RCCMSG,RCDOM,RCEDT,RCJOB,RCSCE,RCSTA,RCTYP,RCVAR,RCSITE,RCXMY,RCXMZ,RCXTYP
- +10 SET RCXMZ=XMZ
- SET RCJOB=$JOB
- +11 DO READ
- +12 DO SEND
- +13 DO TASK
- +14 SET XMZ=RCXMZ
- SET XMSER="S.RC RC SERV"
- DO REMSBMSG^XMA1C
- +15 KILL XMCHAN,XMDUZ,XMDUN,XMFROM,XMREC,XMSER,XMXX,XMY,XMZ
- Q QUIT
- +1 ;
- READ ;READ TRANSMISSION CHK FIRST LINE PUT MESSAGE IN XTMP
- +1 NEW II,RCEND,RCNT,XMRG,XMER,X2
- +2 SET RCNT=0
- SET RCCMSG=""
- SET RCSITE=$$SITE^RCMSITE
- SET RCDOM=$GET(XMFROM)
- +3 FOR II=0:0
- Begin DoDot:1
- +4 XECUTE XMREC
- SET RCNT=RCNT+1
- +5 IF $GET(XMER)<0
- Begin DoDot:2
- +6 IF $GET(RCEND)=""
- SET RCCMSG="E;Incomplete message from Regional Counsel"
- +7 IF '$TEST
- SET RCCMSG="C;AR accepted "_RCNT_" lines successfully."
- +8 SET RCBDT=$PIECE($GET(RCEND),"$",4)
- SET RCEDT=$PIECE($GET(RCEND),"$",5)
- +9 ; I +$P(RCVAR,U,5),$D(^XTMP(RCXTYP,RCJOB,0)) S $P(^XTMP(RCXTYP,RCJOB,0),"^",5)=RCNT
- End DoDot:2
- QUIT
- +10 IF RCNT=1
- DO CHK1
- IF $GET(RCCMSG)]""
- QUIT
- +11 IF ($PIECE(XMRG,"$",2)="END")!($PIECE(XMRG,"$",3)="END")
- SET RCEND=XMRG
- SET RCNT=RCNT-1
- QUIT
- +12 IF '$LENGTH(XMRG)
- SET RCNT=RCNT-1
- QUIT
- +13 IF +$PIECE(RCVAR,U,5)
- SET ^XTMP(RCXTYP,RCXMZ,RCNT)=XMRG
- End DoDot:1
- if $GET(RCCMSG)]""
- QUIT
- +14 QUIT
- +15 ;
- SEND ;CONFIRMATION, ERROR, ORIGINAL MESSAGE TRANSPORT
- +1 ;I message is the original send confirmation or error to RC
- +2 ;INPUT: RCCMSG from Read module always set
- +3 ; RCVAR if exists
- +4 ;I message is a Confirmation or Error from RC to site quit
- +5 IF $PIECE(RCCMSG,";",1)="Q"
- GOTO SENDQ
- +6 SET RETRY=0
- +7 ;
- XMB NEW LN,RCCOM,RCSUB,RCWHO,RETRY,XMDUZ,XMSUB,XMTEXT,XMY,X,Y
- +1 ;Line below may not be needed
- +2 ;I confirmation don't send to anyone.
- +3 IF $GET(RCDOM)=""
- SET RCDOM=$$RCDOM^RCRCUTL
- +4 if $GET(XMFROM)]""
- SET XMY(XMFROM)=""
- +5 ;S RCWHO="S.RC RC SERV@"_RCDOM,XMY(RCWHO)=""
- +6 SET RCWHO=RCDOM
- SET XMY(RCWHO)=""
- +7 SET Y=DT
- DO D^DIQ
- +8 SET LN(1)="$$RC$"_$GET(RCTYP,"UNK")_"$"_$EXTRACT(RCCMSG,1)_"$"_$GET(RCSITE,"UNK")_"$"
- +9 SET LN(2)="Status: Mail Message #("_XMZ_") received at the VAMC "_$GET(RCSITE,"UNK")_" system on "_Y
- +10 SET LN(3)=$SELECT($EXTRACT(RCCMSG,1)="E":"Error ",1:"")_"Message: "_$PIECE(RCCMSG,";",2)
- +11 SET LN(4)="Desc.: "_$PIECE($GET(RCVAR),U,4)
- +12 SET (RCSUB,XMSUB)="AR/RC - "_$GET(RCSITE,"UNK")_" "_$SELECT($EXTRACT(RCCMSG,1)="C":"CONFIRMATION ("_$GET(RCTYP,"UNK")_")",1:"TRANSMISSION ("_$GET(RCTYP,"UNK")_") ERROR")_" MESSAGE"
- +13 SET XMTEXT="LN("
- SET XMDUZ="ACCOUNTS RECEIVABLE RC SERVER"
- +14 DO ^XMD
- IF XMZ<1
- SET RETRY=RETRY+1
- IF RETRY<100
- GOTO XMB
- +15 SET RCCOM=LN(3)
- +16 DO ENT^RCRCXMS(XMZ,RCSUB,RCWHO,RCCOM)
- SENDQ QUIT
- +1 ;
- CHK1 ;CHECK FIRST LINE OF TRANSMISSION
- +1 ;First Line Syntax:
- +2 ;$$RC$S1$$sta#prefix$RC Address
- +3 ; o first four characters must be $$RC$
- +4 ; o $ piece 4 required must be a server code in routine RCRCVAR
- +5 ; o $ piece 5 will be "C" for a confirmation message or
- +6 ; "E" for error receiving the message
- +7 ; "" for the original transmission of a message
- +8 ; o $ piece 6 station number
- +9 ; o $ piece 7 is the RC address to send back to at RCDOM
- +10 ;Last Line Syntax: $END$#oflines$
- +11 ; $END$#oflines$Beg.Ref.DT$End.Ref.DT (Rec Rept. 4 of 4)
- +12 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
- +13 ;INPUT: XMRG - First line of mail message
- +14 ;OUTPUT: RCVAR - Server Code^(C,E,O)^Recipient^desc.^0or1^taskroutine
- +15 ; or Killed
- +16 ; RCCMSG - Error message
- +17 ; RCSTA - Station Number
- +18 ; RCXMY - send message to
- +19 ; RCJOB - $J
- +20 ;
- +21 IF $EXTRACT(XMRG,1,5)'="$$RC$"
- SET RCCMSG="E;RC Server at site is unable to interpret the first line of this message."
- GOTO CHK1Q
- +22 SET RCSCE=$PIECE(XMRG,"$",5)
- SET RCSCE=$SELECT(RCSCE="C":RCSCE,RCSCE="E":RCSCE,RCSCE="":"O",1:"UNK")
- +23 SET RCTYP=$PIECE(XMRG,"$",4)
- SET RCVAR=$$CHK^RCRCVAR(RCTYP,RCSCE)
- +24 IF $PIECE(RCVAR,";",1)="E"
- SET RCCMSG=RCVAR
- KILL RCVAR
- GOTO CHK1Q
- +25 SET RCSTA=$PIECE(XMRG,"$",6)
- +26 SET RCXMY=$PIECE(XMRG,"$",7)
- +27 SET RCDOM=$GET(XMFROM)
- +28 ; If original message needs an XTMP global initialize it
- +29 IF +$PIECE(RCVAR,U,5)
- DO XTMP(RCTYP,$PIECE(RCVAR,U,4))
- +30 DO FILE
- +31 IF "CE"[RCSCE
- SET RCCMSG="Q;"
- CHK1Q QUIT
- +1 ;
- TASK ;If message is original fire off the background job
- +1 ;fire off the background task now. (The time the server is run.)
- +2 IF $GET(RCSCE)="O"
- IF $EXTRACT($GET(RCCMSG),1)'="E"
- DO TASK^RCRCRR
- TASKQ QUIT
- +1 ;
- FILE ;Update AR Transmission File
- +1 NEW DA,DIE,DR,RCCOM,RCX,X,Y
- +2 IF RCSCE="O"
- Begin DoDot:1
- +3 SET RCSUB=$$SUBGET^XMGAPI0(RCXMZ)
- +4 SET RCCOM="RC sent Request Action ("_RCTYP_")."
- +5 DO ENT^RCRCXMS(RCXMZ,$GET(RCSUB),"RC SERVER AT "_RCSTA,RCCOM)
- End DoDot:1
- GOTO FILEQ
- +6 ;If Message is a Confirm or Error from RC
- +7 XECUTE XMREC
- SET RCNT=RCNT+1
- IF XMRG'["STATUS:"
- GOTO FILEQ
- +8 SET RCX=+$PIECE(XMRG,"Message ",2)
- +9 SET DA=$ORDER(^RCT(349.3,"B",RCX,0))
- +10 IF DA
- SET DIE="^RCT(349.3,"
- SET DR=$SELECT(RCSCE="E":6,1:5)_"////^S X="_RCXMZ
- DO ^DIE
- +11 IF 'DA
- IF RCSCE="E"
- Begin DoDot:1
- +12 SET RCSUB=$$SUBGET^XMGAPI0(RCXMZ)
- +13 SET RCCOM="RC sent Error message ("_RCTYP_")."
- +14 DO ENT^RCRCXMS(RCXMZ,$GET(RCSUB),"RC SERVER AT "_RCSTA,RCCOM)
- End DoDot:1
- FILEQ QUIT
- +1 ;
- XTMP(RCTYP,RCDSC) ;INITIALIZE TOP XTMP Global for Server Type
- +1 ;INPUT : Type of server message must be passed
- +2 ;OUTPUT: XTMP global gets created for this server type
- +3 ; : RCXTYP gets set to PRCA_rctype(MR1,RR1,TR,CL...)
- +4 ; : RCJOB Job Number
- +5 ;XTMP purge data will be 30 days past the create date
- +6 NEW RCDT,X,X1,X2,Y,%,%H,%I
- +7 DO NOW^%DTC
- SET (X1,RCDT)=X
- SET X2=30
- DO C^%DTC
- +8 SET RCXTYP="PRCA"_RCTYP
- KILL ^XTMP(RCXTYP,RCXMZ)
- +9 SET ^XTMP(RCXTYP,RCXMZ,0)=X_"^"_RCDT_"^"_RCDSC_U_RCXMZ
- +10 QUIT
- +11 ;RCRCSRV