- RCCPCSV1 ;WASH-ISC@ALTOONA,PA/LDB-Receive and Process CCPC messages ;1/6/97 2:54 PM
- ;;4.5;Accounts Receivable;**34,70,76,130,153**;Mar 20, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- IS ;INVALID STATEMENT
- D CHKTRAN(LABEL)
- S ERR="The following statements did not print due to errors:" D ERRMSG
- S ERR=" " D ERRMSG
- S ERR=" KEY ERROR" D ERRMSG S ERR=" " D ERRMSG
- D ID
- S ERR="If these errors are corrected, these statements will not print until" D ERRMSG S ERR="the next billing cycle." D ERRMSG
- Q
- ;
- ID ;INVALID STATEMENT DETAIL ERROR
- F S RCMSG=$O(^TMP($J,"MSG",RCMSG)) Q:'RCMSG D
- .I $P(^TMP($J,"MSG",RCMSG),"^")'="ID" S ERR="ERROR IN READING CCPC ERROR RECORD" D ERRMSG Q
- .S KEY=$P(^TMP($J,"MSG",RCMSG),"^",2),KEY=$TR(KEY," ",""),KEY=$E(KEY,$F(KEY,$$SITE^RCMSITE),999)
- .I KEY']"" D KEYERR Q
- .S DEB=$O(^RCPS(349.2,"AKEY",KEY,0)) I 'DEB D KEYERR Q
- .S ERROR=$P(^TMP($J,"MSG",RCMSG),"^",3),^RCPS(349.2,+DEB,5)=ERROR
- .F RCX=1:5:21 S RCX1=RCX+4 S ERR(0)=$E(ERROR,RCX,RCX1) Q:ERR(0)="" D
- ..S ERR(1)=$O(^RCPSE(349.7,"B",ERR(0),""))
- ..I 'ERR(1) S ERR="NO ERROR DESCRIPTION FOR ERROR CODE: "_ERR(0)
- ..I ERR(1) S ERR=$P(^RCPSE(349.7,+ERR(1),0),"^",4)
- ..S ERR=KEY_" "_ERR(0)_" "_ERR
- ..D ERRMSG
- ..S ERR=" " D ERRMSG
- .S ^RCPS(349.2,+DEB,5)=$P(^TMP($J,"MSG",RCMSG),"^",3)
- .S ^RCPS(349.2,"AD","E",+DEB)=""
- Q
- ;
- ;
- KEYERR ;SEND MESSAGE TO MAIL GROUP INDICATING NO KEY
- S ERR="CCPC ERROR MESSAGE - NO AR KEY ID FOR CCPC KEY: "_KEY D ERRMSG
- S ERR="This patient record is corrupted. Please contact IRM." D ERRMSG
- S ERR=" " D ERRMSG
- Q
- ;
- PA ;STATEMENT ACKNOWLEDGEMENT
- N STDT,SSTDT
- Q:$P(RCTR,"^")'="PA"
- D CHKTRAN(LABEL)
- S SDAT=$P(RCTR,"^",7) S SDAT=$E(SDAT,1,2)_"/"_$E(SDAT,3,4)_"/"_$E(SDAT,5,8) S X=SDAT D ^%DT S SDAT=Y
- S STOT=+$P(RCTR,"^",6)
- S SEQ=+$P(RCTR,"^",3)
- F S RCMSG=$O(^TMP($J,"MSG",RCMSG)) Q:'RCMSG D
- .S RCTR=^TMP($J,"MSG",RCMSG)
- .Q:$P(RCTR,"^")'="AD"
- .S KEY=$P(RCTR,"^",2),KEY=$TR(KEY," ",""),KEY=$E(KEY,$F(KEY,$$SITE^RCMSITE),999)
- .I KEY']"" D KEYERR Q
- .S DEB=$O(^RCPS(349.2,"AKEY",KEY,0))
- .I 'DEB D KEYERR Q
- .S END=$P(^RCPS(349.2,+DEB,0),"^",10)
- .S:'END END=$O(^RCPS(349.2,0)),END=$P($G(^(+END,0)),"^",10)
- .F P=13:1:17 S SBAL(P)=$P(^RCPS(349.2,+DEB,0),"^",P)
- .;update patient statement date in 341 to end process time
- .D OPEN^RCEVDRV1(2,$P(^RCD(340,DEB,0),U),END,DUZ,$$SITE^RCMSITE,.ERR,.EVN,SBAL(13)_U_SBAL(14)_U_SBAL(15)_U_SBAL(16)_U_SBAL(17))
- .I EVN S DR=".07////"_END_";.11////"_1,DA=+EVN,DIE="^RC(341," D ^DIE K DIE,DR,DA
- .I EVN S $P(^RC(341,+EVN,6),"^")=$G(SDAT)
- .;update bill file 430 letter fields
- .NEW BN,DA,DIC,DIE,DR,II,LET,NOT,X,Y
- .S DIE="^PRCA(430,",NOT=0,BN=0
- .F S BN=$O(^PRCA(430,"AS",DEB,16,BN)) Q:'BN S DA=BN D
- ..S LET=$G(^PRCA(430,BN,6))
- ..I $P(LET,"^",21)>END Q
- ..S END=$G(SDAT)
- ..F II=1:1:4 Q:$P(LET,U,II)=END I $P(LET,U,II)="" S DR=$S(II=1:61,II=2:62,II=3:63,1:68)_"////^S X="_END_";68.1////^S X="_END D ^DIE Q
- .S ^RCPS(349.2,+DEB,6)=1
- PAMAIL S XMSUB="Patient Acknowledgments received from CCPC."
- S XMY("G.RCCPC STATEMENTS")="",XMDUZ="AR PACKAGE",XMTEXT="MSG("
- S MSG(1)="Patient acknowledgment message "_$G(XMZ)_" received."
- S MSG(2)="This means that CCPC has printed patient statements for this statement period."
- D ^XMD
- Q
- ;CODE BELOW NO LONGER NEEDED SINCE INTEREST/ADMIN UPDATE NOW DONE
- ;WHEN STATEMENTS ARE GENERATED.
- N ZTDESC,ZTDTH,ZTRTN,ZTSAVE
- S DATE=$G(SDAT) Q:'DATE
- S ZTDTH=$S(DT'>SDAT:$$FMADD^XLFDT(SDAT,1),1:$$FMADD^XLFDT(DT,1))_".02"
- S ZTIO="",ZTRTN="FIRSTPTY^RCBECHGS",ZTDESC="Accrue interest/admin charges"
- S ZTSAVE("RCUPDATE")=DATE
- D ^%ZTLOAD
- Q
- ;
- CHKTRAN(LABEL) ;Check for incomplete message from CCPC
- Q:$G(LABEL)']""
- S LABEL(1)=+$O(^RCT(349.1,"B",LABEL,0))
- I LABEL(1) S:$P(^TMP($J,"MSG",RCMSG),"^",2)=$P(^TMP($J,"MSG",RCMSG),"^",3) $P(^RCT(349.1,+LABEL(1),4),"^",1,2)=$P(^TMP($J,"MSG",RCMSG),"^",2,3),$P(^RCT(349.1,+LABEL(1),4),"^",3)=$G(XMZ)
- Q
- ;
- TRANCHK ;Check for complete ACK transmission
- N MSG,RCT,SEG,SEQ,X
- F RCT=3,4 I $P($G(^RCT(349.1,+RCT,4)),"^")'=$P($G(^RCT(349.1,+RCT,4)),"^",2) D
- .S XMDUZ="AR PACKAGE"
- .S XMSUB="CCPC ACKNOWLEDGMENT TRANSMISSION(S) INCOMPLETE"
- .I $O(^XMB(3.8,"B","RCCPC STATEMENTS",0)) S XMY("G.RCCPC STATEMENTS")="" E S XMY(.5)=""
- .S XMTEXT="MSG("
- .S SEG=$S(RCT=3:"IS",1:"PA")
- .S SEG(1)=$P(^RCT(349.1,+RCT,4),"^",2)
- .S MSG(2)="The last "_SEG_" segment message received from CCPC was numbered "_SEG(1)_"."
- .S MSG(3)="This was not labeled the final message in that segment type transmission."
- .S MSG(4)="This may cause patient statement information to be missing."
- .S MSG(5)="The last message number received was "_$P($G(^RCT(349.1,RCT,4)),"^",3)
- .S MSG(6)="Please contact the CCPC in Austin."
- .D ^XMD
- Q
- ;
- ;
- IT ;INVALID TRANSMISSION
- S ERR="The CCPC patient statement messages were not accepted by CCPC" D ERRMSG
- S ERR="due to the following error(s):" D ERRMSG
- S ERR=" " D ERRMSG
- S RCMSG=1 F S RCMSG=$O(^TMP($J,"MSG",RCMSG)) Q:'RCMSG D
- .S MSG=^TMP($J,"MSG",RCMSG)
- .S MSG=$P(MSG,"^",8)
- .F RCX=1:5:21 S RCX1=RCX+4 S ERROR=$E(MSG,RCX,RCX1) Q:ERROR="" D
- ..S ERR(1)=$O(^RCPSE(349.7,"B",ERROR,""))
- ..I 'ERR(1) S ERR="NO ERROR DESCRIPTION FOR ERROR CODE: "_ERROR
- ..I ERR(1) S ERR=$P(^RCPSE(349.7,+ERR(1),0),"^",4),ERR=ERROR_" "_ERR
- ..I ERR(1) S:$P(^RCPSE(349.7,+ERR(1),0),"^",3)="R" RE=1
- ..D ERRMSG
- S ERR=" " D ERRMSG
- S ERR="Please contact IRM."
- D ERRMSG
- Q
- ;
- ERRMSG ;ERROR MESSAGE
- S LN=LN+1,^TMP($J,"ERR",LN)=ERR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCCPCSV1 5561 printed Jan 18, 2025@02:44:30 Page 2
- RCCPCSV1 ;WASH-ISC@ALTOONA,PA/LDB-Receive and Process CCPC messages ;1/6/97 2:54 PM
- +1 ;;4.5;Accounts Receivable;**34,70,76,130,153**;Mar 20, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- IS ;INVALID STATEMENT
- +1 DO CHKTRAN(LABEL)
- +2 SET ERR="The following statements did not print due to errors:"
- DO ERRMSG
- +3 SET ERR=" "
- DO ERRMSG
- +4 SET ERR=" KEY ERROR"
- DO ERRMSG
- SET ERR=" "
- DO ERRMSG
- +5 DO ID
- +6 SET ERR="If these errors are corrected, these statements will not print until"
- DO ERRMSG
- SET ERR="the next billing cycle."
- DO ERRMSG
- +7 QUIT
- +8 ;
- ID ;INVALID STATEMENT DETAIL ERROR
- +1 FOR
- SET RCMSG=$ORDER(^TMP($JOB,"MSG",RCMSG))
- if 'RCMSG
- QUIT
- Begin DoDot:1
- +2 IF $PIECE(^TMP($JOB,"MSG",RCMSG),"^")'="ID"
- SET ERR="ERROR IN READING CCPC ERROR RECORD"
- DO ERRMSG
- QUIT
- +3 SET KEY=$PIECE(^TMP($JOB,"MSG",RCMSG),"^",2)
- SET KEY=$TRANSLATE(KEY," ","")
- SET KEY=$EXTRACT(KEY,$FIND(KEY,$$SITE^RCMSITE),999)
- +4 IF KEY']""
- DO KEYERR
- QUIT
- +5 SET DEB=$ORDER(^RCPS(349.2,"AKEY",KEY,0))
- IF 'DEB
- DO KEYERR
- QUIT
- +6 SET ERROR=$PIECE(^TMP($JOB,"MSG",RCMSG),"^",3)
- SET ^RCPS(349.2,+DEB,5)=ERROR
- +7 FOR RCX=1:5:21
- SET RCX1=RCX+4
- SET ERR(0)=$EXTRACT(ERROR,RCX,RCX1)
- if ERR(0)=""
- QUIT
- Begin DoDot:2
- +8 SET ERR(1)=$ORDER(^RCPSE(349.7,"B",ERR(0),""))
- +9 IF 'ERR(1)
- SET ERR="NO ERROR DESCRIPTION FOR ERROR CODE: "_ERR(0)
- +10 IF ERR(1)
- SET ERR=$PIECE(^RCPSE(349.7,+ERR(1),0),"^",4)
- +11 SET ERR=KEY_" "_ERR(0)_" "_ERR
- +12 DO ERRMSG
- +13 SET ERR=" "
- DO ERRMSG
- End DoDot:2
- +14 SET ^RCPS(349.2,+DEB,5)=$PIECE(^TMP($JOB,"MSG",RCMSG),"^",3)
- +15 SET ^RCPS(349.2,"AD","E",+DEB)=""
- End DoDot:1
- +16 QUIT
- +17 ;
- +18 ;
- KEYERR ;SEND MESSAGE TO MAIL GROUP INDICATING NO KEY
- +1 SET ERR="CCPC ERROR MESSAGE - NO AR KEY ID FOR CCPC KEY: "_KEY
- DO ERRMSG
- +2 SET ERR="This patient record is corrupted. Please contact IRM."
- DO ERRMSG
- +3 SET ERR=" "
- DO ERRMSG
- +4 QUIT
- +5 ;
- PA ;STATEMENT ACKNOWLEDGEMENT
- +1 NEW STDT,SSTDT
- +2 if $PIECE(RCTR,"^")'="PA"
- QUIT
- +3 DO CHKTRAN(LABEL)
- +4 SET SDAT=$PIECE(RCTR,"^",7)
- SET SDAT=$EXTRACT(SDAT,1,2)_"/"_$EXTRACT(SDAT,3,4)_"/"_$EXTRACT(SDAT,5,8)
- SET X=SDAT
- DO ^%DT
- SET SDAT=Y
- +5 SET STOT=+$PIECE(RCTR,"^",6)
- +6 SET SEQ=+$PIECE(RCTR,"^",3)
- +7 FOR
- SET RCMSG=$ORDER(^TMP($JOB,"MSG",RCMSG))
- if 'RCMSG
- QUIT
- Begin DoDot:1
- +8 SET RCTR=^TMP($JOB,"MSG",RCMSG)
- +9 if $PIECE(RCTR,"^")'="AD"
- QUIT
- +10 SET KEY=$PIECE(RCTR,"^",2)
- SET KEY=$TRANSLATE(KEY," ","")
- SET KEY=$EXTRACT(KEY,$FIND(KEY,$$SITE^RCMSITE),999)
- +11 IF KEY']""
- DO KEYERR
- QUIT
- +12 SET DEB=$ORDER(^RCPS(349.2,"AKEY",KEY,0))
- +13 IF 'DEB
- DO KEYERR
- QUIT
- +14 SET END=$PIECE(^RCPS(349.2,+DEB,0),"^",10)
- +15 if 'END
- SET END=$ORDER(^RCPS(349.2,0))
- SET END=$PIECE($GET(^(+END,0)),"^",10)
- +16 FOR P=13:1:17
- SET SBAL(P)=$PIECE(^RCPS(349.2,+DEB,0),"^",P)
- +17 ;update patient statement date in 341 to end process time
- +18 DO OPEN^RCEVDRV1(2,$PIECE(^RCD(340,DEB,0),U),END,DUZ,$$SITE^RCMSITE,.ERR,.EVN,SBAL(13)_U_SBAL(14)_U_SBAL(15)_U_SBAL(16)_U_SBAL(17))
- +19 IF EVN
- SET DR=".07////"_END_";.11////"_1
- SET DA=+EVN
- SET DIE="^RC(341,"
- DO ^DIE
- KILL DIE,DR,DA
- +20 IF EVN
- SET $PIECE(^RC(341,+EVN,6),"^")=$GET(SDAT)
- +21 ;update bill file 430 letter fields
- +22 NEW BN,DA,DIC,DIE,DR,II,LET,NOT,X,Y
- +23 SET DIE="^PRCA(430,"
- SET NOT=0
- SET BN=0
- +24 FOR
- SET BN=$ORDER(^PRCA(430,"AS",DEB,16,BN))
- if 'BN
- QUIT
- SET DA=BN
- Begin DoDot:2
- +25 SET LET=$GET(^PRCA(430,BN,6))
- +26 IF $PIECE(LET,"^",21)>END
- QUIT
- +27 SET END=$GET(SDAT)
- +28 FOR II=1:1:4
- if $PIECE(LET,U,II)=END
- QUIT
- IF $PIECE(LET,U,II)=""
- SET DR=$SELECT(II=1:61,II=2:62,II=3:63,1:68)_"////^S X="_END_";68.1////^S X="_END
- DO ^DIE
- QUIT
- End DoDot:2
- +29 SET ^RCPS(349.2,+DEB,6)=1
- End DoDot:1
- PAMAIL SET XMSUB="Patient Acknowledgments received from CCPC."
- +1 SET XMY("G.RCCPC STATEMENTS")=""
- SET XMDUZ="AR PACKAGE"
- SET XMTEXT="MSG("
- +2 SET MSG(1)="Patient acknowledgment message "_$GET(XMZ)_" received."
- +3 SET MSG(2)="This means that CCPC has printed patient statements for this statement period."
- +4 DO ^XMD
- +5 QUIT
- +6 ;CODE BELOW NO LONGER NEEDED SINCE INTEREST/ADMIN UPDATE NOW DONE
- +7 ;WHEN STATEMENTS ARE GENERATED.
- +8 NEW ZTDESC,ZTDTH,ZTRTN,ZTSAVE
- +9 SET DATE=$GET(SDAT)
- if 'DATE
- QUIT
- +10 SET ZTDTH=$SELECT(DT'>SDAT:$$FMADD^XLFDT(SDAT,1),1:$$FMADD^XLFDT(DT,1))_".02"
- +11 SET ZTIO=""
- SET ZTRTN="FIRSTPTY^RCBECHGS"
- SET ZTDESC="Accrue interest/admin charges"
- +12 SET ZTSAVE("RCUPDATE")=DATE
- +13 DO ^%ZTLOAD
- +14 QUIT
- +15 ;
- CHKTRAN(LABEL) ;Check for incomplete message from CCPC
- +1 if $GET(LABEL)']""
- QUIT
- +2 SET LABEL(1)=+$ORDER(^RCT(349.1,"B",LABEL,0))
- +3 IF LABEL(1)
- if $PIECE(^TMP($JOB,"MSG",RCMSG),"^",2)=$PIECE(^TMP($JOB,"MSG",RCMSG),"^",3)
- SET $PIECE(^RCT(349.1,+LABEL(1),4),"^",1,2)=$PIECE(^TMP($JOB,"MSG",RCMSG),"^",2,3)
- SET $PIECE(^RCT(349.1,+LABEL(1),4),"^",3)=$GET(XMZ)
- +4 QUIT
- +5 ;
- TRANCHK ;Check for complete ACK transmission
- +1 NEW MSG,RCT,SEG,SEQ,X
- +2 FOR RCT=3,4
- IF $PIECE($GET(^RCT(349.1,+RCT,4)),"^")'=$PIECE($GET(^RCT(349.1,+RCT,4)),"^",2)
- Begin DoDot:1
- +3 SET XMDUZ="AR PACKAGE"
- +4 SET XMSUB="CCPC ACKNOWLEDGMENT TRANSMISSION(S) INCOMPLETE"
- +5 IF $ORDER(^XMB(3.8,"B","RCCPC STATEMENTS",0))
- SET XMY("G.RCCPC STATEMENTS")=""
- IF '$TEST
- SET XMY(.5)=""
- +6 SET XMTEXT="MSG("
- +7 SET SEG=$SELECT(RCT=3:"IS",1:"PA")
- +8 SET SEG(1)=$PIECE(^RCT(349.1,+RCT,4),"^",2)
- +9 SET MSG(2)="The last "_SEG_" segment message received from CCPC was numbered "_SEG(1)_"."
- +10 SET MSG(3)="This was not labeled the final message in that segment type transmission."
- +11 SET MSG(4)="This may cause patient statement information to be missing."
- +12 SET MSG(5)="The last message number received was "_$PIECE($GET(^RCT(349.1,RCT,4)),"^",3)
- +13 SET MSG(6)="Please contact the CCPC in Austin."
- +14 DO ^XMD
- End DoDot:1
- +15 QUIT
- +16 ;
- +17 ;
- IT ;INVALID TRANSMISSION
- +1 SET ERR="The CCPC patient statement messages were not accepted by CCPC"
- DO ERRMSG
- +2 SET ERR="due to the following error(s):"
- DO ERRMSG
- +3 SET ERR=" "
- DO ERRMSG
- +4 SET RCMSG=1
- FOR
- SET RCMSG=$ORDER(^TMP($JOB,"MSG",RCMSG))
- if 'RCMSG
- QUIT
- Begin DoDot:1
- +5 SET MSG=^TMP($JOB,"MSG",RCMSG)
- +6 SET MSG=$PIECE(MSG,"^",8)
- +7 FOR RCX=1:5:21
- SET RCX1=RCX+4
- SET ERROR=$EXTRACT(MSG,RCX,RCX1)
- if ERROR=""
- QUIT
- Begin DoDot:2
- +8 SET ERR(1)=$ORDER(^RCPSE(349.7,"B",ERROR,""))
- +9 IF 'ERR(1)
- SET ERR="NO ERROR DESCRIPTION FOR ERROR CODE: "_ERROR
- +10 IF ERR(1)
- SET ERR=$PIECE(^RCPSE(349.7,+ERR(1),0),"^",4)
- SET ERR=ERROR_" "_ERR
- +11 IF ERR(1)
- if $PIECE(^RCPSE(349.7,+ERR(1),0),"^",3)="R"
- SET RE=1
- +12 DO ERRMSG
- End DoDot:2
- End DoDot:1
- +13 SET ERR=" "
- DO ERRMSG
- +14 SET ERR="Please contact IRM."
- +15 DO ERRMSG
- +16 QUIT
- +17 ;
- ERRMSG ;ERROR MESSAGE
- +1 SET LN=LN+1
- SET ^TMP($JOB,"ERR",LN)=ERR
- +2 QUIT