Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCCPCML

RCCPCML.m

Go to the documentation of this file.
  1. RCCPCML ;WASH-ISC@ALTOONA,PA/LDB-Send CCPC transmission ;12/19/96 4:16 PM
  1. V ;;4.5;Accounts Receivable;**34,80,93,118,133,140,160,165,187,195,206,223,260**;Mar 20, 1995;Build 2
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. TRAN ;called from RCCPC TRANSMIT option to interactively allow transmission of CCPC mesages
  1. N %DT,DTOUT,SDT,X,Y,ZTRTN,ZTSAVE,ZTDESC,ZTIO
  1. I '$D(^XUSEC("RCCPC TRANSMIT",DUZ)) W *7,*7,!,"You do not have access to do this." Q
  1. S %DT="AEXP"
  1. S %DT("A")="Enter statement date as it will appear on these statements: "
  1. S SDT=$O(^RCPS(349.2,0)) I 'SDT W !,"You need to build the CCPC file." Q
  1. S SDT=$P($P($G(^RCPS(349.2,SDT,0)),"^",10),".") I 'SDT W !,"Your CCPC statement file (349.2) is corrupted. Please rebuild it." Q
  1. S SDT=$E(SDT,1,5)_$$STDY^RCCPCFN
  1. S %DT("B")=$$FMTE^XLFDT(SDT)
  1. D ^%DT Q:(X="^")!($D(DTOUT))!(Y=-1)
  1. S SDT=$E(Y,1,5)_$$STDY^RCCPCFN,SDT=$$STDT^RCCPCFN(SDT)
  1. S ZTSAVE("SDT")="",ZTRTN="RETRAN^RCCPCML",ZTIO="",ZTDESC="Re-transmit CCPC patient statements -user activated"
  1. D ^%ZTLOAD
  1. Q
  1. ;
  1. EN ;called from background job
  1. N DA,DIK,LPRINT
  1. S SDT=$$STDT^RCCPCFN("")
  1. RETRAN N DA,DIK,ERROR,RCT,X
  1. S (ERROR,X)=0 F S X=$O(^RCPS(349.2,X)) Q:'X I $G(^(X,6)) S ERROR=1,NM=0 D ERROR Q
  1. I $G(ERROR) D EXIT Q
  1. K ^TMP($J)
  1. S X=0 F S X=$O(^RCT(349,"B",X)) Q:X="" I $P(X,".")="PS" S DA=$O(^RCT(349,"B",X,0)),DIK="^RCT(349," D ^DIK
  1. F X="PA","IS","IT" S RCT=$O(^RCT(349.1,"B",X,0)) I RCT K ^RCT(349.1,+RCT,4)
  1. N %,ADD,AMT,ERROR,L,LN,M,MSG,MCT,MPT1,MTOT,NM,P,PD,PD0,PSN,PT,PT0,PHCT,RCM,RTY,TAMT,TMSG,SZ,TRDESC
  1. D DT^DICRW
  1. S (ERROR,RTY)=0
  1. S X=$O(^RCT(349.1,"B","PS",0))
  1. I X,$P($G(^RCT(349.1,+X,0)),"^",3) S X=$P($G(^RCT(349.1,+X,3)),"^",3)
  1. I X']"" S ERROR=6,NM=0 D ERROR,EXIT Q
  1. D PHCT I 'PHCT S ERROR=1,NM=0 D ERROR,EXIT Q
  1. S MTOT=$O(^TMP($J,"MCT",""),-1)
  1. S MCT=0 F S MCT=$O(^TMP($J,"MCT",MCT)) Q:'MCT D PS
  1. EXIT D ERRML^RCCPCML1
  1. K SDT,^TMP($J)
  1. Q
  1. ;
  1. F349 ;Get PS segment entry
  1. N DA,D0,DIC,DLAYGO,X
  1. S ERROR=0 K DD,DO S DIC="^RCT(349,",DIC(0)="L",DLAYGO=349,X="PS."_$TR($$FMTE^XLFDT(DT,"2D"),"/",".")_"."_RCM D FILE^DICN
  1. I Y<0 S RTY=RTY+1 G F349:RTY<4 S ERROR=2,NM=0 D ERROR Q
  1. S PSN=+Y
  1. Q
  1. ;
  1. PS ;Build PS,PH,PD segments and messages
  1. S PSN=$O(^TMP($J,"MCT",MCT,0))
  1. S $P(^RCT(349,+PSN,0),"^",3,10)=MCT_"^"_MTOT_"^"_$$SITE^RCMSITE()_"^"_$$FP^RCCPCFN_"^"_+^TMP($J,"MCT",MCT)_"^"_$P(^TMP($J,"MCT",MCT),"^",2)_"^"_SDT_"^"_$$STM^RCCPCFN
  1. S LN=+PSN,^TMP($J,"MSG",LN)=$P($G(^RCT(349,+PSN,0)),"^",2,10)_"^|"
  1. S MPT1=$P(^TMP($J,"MCT",MCT),"^",3)
  1. S PT=$S(MCT=1:0,1:$P(^TMP($J,"MCT",MCT-1),"^",3))
  1. F S PT=$O(^RCPS(349.2,PT)) Q:PT=$O(^RCPS(349.2,+($P(^TMP($J,"MCT",MCT),"^",3)))) D
  1. .Q:$D(^TMP($J,"ERRPT",+PT))
  1. .S PT0=^RCPS(349.2,+PT,0)
  1. .S LN=LN+1 S ^TMP($J,"MSG",LN)="PH^"_$$SITE^RCMSITE_$$KEY^RCCPCFN(+PT)_"^"_$$NM^RCCPCFN(+PT)_"^"
  1. .S ADD=$G(^RCPS(349.2,+PT,1))
  1. .;
  1. .;Remove special characters causing problems (WIM-0402-20728)
  1. .I ADD["~" S ADD=$TR(ADD,"~","") ;Remove tilde
  1. .I ADD["|" S ADD=$TR(ADD,"|","") ;Remove the pipe symbol
  1. .;
  1. .;Debtor needs large print (font) IF LPRINT=1
  1. .S LPRINT=$G(^RCPS(349.2,+PT,7)) S:LPRINT="" LPRINT=0
  1. .;
  1. .F P=1:1:7 S $P(^TMP($J,"MSG",LN),"^",P+5)=$S($P(ADD,"^",P)]"":$P(ADD,"^",P),1:"")
  1. .S ^TMP($J,"MSG",LN)=^TMP($J,"MSG",LN)_"^"
  1. .S LN=LN+1
  1. .F X=4:1:8 S $P(AMT,"^",X-3)=$$HEX^RCCPCFN($P(PT0,"^",X))
  1. .;S ^TMP($J,"MSG",LN)=AMT_"^"_$G(^RCPS(349.2,+PT,3))_"^"_$G(^RCPS(349.2,+PT,4))_"^"_$P(^RCPS(349.2,+PT,2,0),"^",4)_"^|"
  1. .S ^TMP($J,"MSG",LN)=AMT_"^"_$G(^RCPS(349.2,+PT,3))_"^"_$G(^RCPS(349.2,+PT,4))_"^"_$O(^RCPS(349.2,+PT,2,""),-1)
  1. .S LN=LN+1 I $P($G(^RCD(340,+PT,0)),";") S ^TMP($J,"MSG",LN)="^"_$$SITE^RCMSITE_$$RJ^XLFSTR($TR($P(^RCD(340,+PT,0),";"),".",""),13,0)
  1. .S ^TMP($J,"MSG",LN)=$G(^TMP($J,"MSG",LN))_"^"_LPRINT_"^|"
  1. .S $P(^RCPS(349.2,+PT,0),"^",11)=+PSN
  1. .S PD=0 F S PD=$O(^RCPS(349.2,+PT,2,PD)) Q:'PD I $D(^(PD,0)) S PD0=^(0) D
  1. ..S AMT(0)=$$HEX^RCCPCFN($P(PD0,"^",3))
  1. ..;Replace special characters causing problem (PRCA*260)
  1. ..S TRDESC=$P(PD0,"^",2)
  1. ..I TRDESC["~" S TRDESC=$TR(TRDESC,"~"," ") ;Replace tilde
  1. ..I TRDESC["|" S TRDESC=$TR(TRDESC,"|"," ") ;Replace the pipe symbol
  1. ..S LN=LN+1,^TMP($J,"MSG",LN)="PD^"_$$DAT^RCCPCFN(+PD0)_"^"_TRDESC_"^"_AMT(0)_"^"_$P(PD0,"^",4)_"^|"
  1. S LN=LN+1,^TMP($J,"MSG",LN)="~"
  1. ;
  1. MAIL ;set up mail message
  1. N L,XMDUZ,XMSUB,XMY,XMZ,Z
  1. S XMSUB=$$SITE^RCMSITE()_" CCPC TRANSMISSION "_SDT
  1. S XMDUZ="AR PACKAGE"
  1. I $O(^XMB(3.8,"B","RCCPC STATEMENTS","")),$P($G(^RC(342,1,0)),"^",12) S XMY("G.RCCPC STATEMENTS")=""
  1. S X=$O(^RCT(349.1,"B","PS",0))
  1. I X,$P($G(^RCT(349.1,+X,0)),"^",3) S X=$P($G(^RCT(349.1,+X,3)),"^")_"@"_$P($G(^RCT(349.1,+X,3)),"^",3) S:$P(X,"@",2)]"" XMY(X)=""
  1. I $P(X,"@",2)']"" D Q
  1. .S ERROR=6,NM=0 D ERROR
  1. S XMDUZ="AR PACKAGE"
  1. D XMZ^XMA2
  1. I XMZ<1 S RTY=RTY+1 G MAIL:RTY<4 S ERROR=5,NM=0 D ERROR Q
  1. S $P(^RCT(349,+PSN,0),"^",11,12)=DT_"^"_XMZ
  1. S (L,L(1))=0 F S L(1)=$O(^TMP($J,"MSG",L(1))) Q:'L(1) S L=L+1,^XMB(3.9,+XMZ,2,L,0)=^TMP($J,"MSG",L(1))
  1. ;S L=$O(^TMP($J,"MSG",""),-1)
  1. S ^XMB(3.9,XMZ,2,0)="^3.92A^"_L_"^"_L_"^"_DT
  1. D ENT1^XMD
  1. D NOW^%DTC
  1. S $P(^RCT(349,+PSN,0),"^",11,12)=%_"^"_XMZ
  1. K ^TMP($J,"MSG")
  1. ;D KILL^XM
  1. Q
  1. ;
  1. PHCT ;PH count
  1. S (ERROR,PT,PHCT,TAMT,SZ)=0,RCM=1
  1. F S PT=$O(^RCPS(349.2,PT)) Q:'PT S ERROR=0 D I ERROR,(ERROR<3) Q
  1. .S SZ(1)=0 D ERRCHK Q:ERROR
  1. .S PT0=^RCPS(349.2,+PT,0)
  1. .S PHCT=PHCT+1
  1. .S SZ=550+SZ,SZ(1)=550
  1. .S:$G(^RCPS(349.2,+PT,1))]"" SZ=SZ+$L(^(1)),SZ(1)=SZ(1)+$L(^(1))
  1. .S:$G(^RCPS(349.2,+PT,3))]"" SZ=SZ+$L(^(3))+1,SZ(1)=SZ(1)+$L(^(3))+1
  1. .S:$G(^RCPS(349.2,+PT,4))]"" SZ=SZ+$L(^(4))+1,SZ(1)=SZ(1)+$L(^(4))+1
  1. .S X=0 F S X=$O(^RCPS(349.2,+PT,2,X)) Q:'X I $D(^(X,0)) S SZ=$L(^(0))+SZ,SZ(1)=SZ(1)+$L(^(0))
  1. .S TAMT=TAMT+$P(^RCPS(349.2,+PT,0),"^",8)
  1. .I SZ>27000 D
  1. ..S RTY=0 D F349 Q:ERROR
  1. ..S TAMT=TAMT-$P(PT0,"^",8)
  1. ..S TAMT=$$HEX^RCCPCFN(TAMT)
  1. ..S ^TMP($J,"MCT",RCM)=(PHCT-1)_"^"_TAMT_"^"_$O(^RCPS(349.2,PT),-1)_"^"_(SZ-SZ(1))
  1. ..S ^TMP($J,"MCT",RCM,+PSN)=""
  1. ..S RCM=RCM+1,PHCT=1
  1. ..S SZ=SZ(1)
  1. ..S TAMT=$P(PT0,"^",8)
  1. I 'PT,$O(^RCPS(349.2,0)) D
  1. .S RTY=0 D F349 Q:ERROR S ^TMP($J,"MCT",RCM)=PHCT_"^"_$$HEX^RCCPCFN(TAMT)_"^"_$O(^RCPS(349.2,PT),-1)
  1. .S ^TMP($J,"MCT",RCM,+PSN)=""
  1. Q
  1. ;
  1. ERROR ;ERROR FILE
  1. I NM=0 S ^TMP($J,"ERROR",ERROR,NM)="" Q
  1. S ^TMP($J,"ERROR",ERROR,NM,$$SSN^RCFN01(+PT))=""
  1. Q
  1. ;
  1. ERRCHK ;Error check
  1. I '$D(^RCPS(349.2,+PT,0)) S ERROR=1,NM=0 D ERROR Q
  1. S PT(1)=PT,PT=$O(^RCPS(349.2,0)) I '$P(^RCPS(349.2,PT,0),"^",18) S ERROR=1,NM=0 D ERROR S PT=PT(1) Q
  1. S PT=PT(1)
  1. I $$KEY^RCCPCFN(+PT)']"" S ERROR=4,NM=$$NAM^RCFN01(+PT) D ERROR S ^TMP($J,"ERRPT",+PT)="" Q
  1. I '$D(^RCPS(349.2,"AKEY",$$KEY^RCCPCFN(+PT))) S ERROR=4,NM=$$NAM^RCFN01(+PT) D ERROR S ^TMP($J,"ERRPT",+PT)="" Q
  1. S ADD=$G(^RCPS(349.2,+PT,1))
  1. F P=1:1:7 S ADD(P)=$S($P(ADD,"^",P)]"":$P(ADD,"^",P),1:"")
  1. I ADD(1)="",ADD(2)="",ADD(3)="",ADD(4)="",ADD(5)="",ADD(6)="" S ERROR=8,NM=$$NAM^RCFN01(+PT) D ERROR S ^TMP($J,"ERRPT",+PT)="" Q
  1. I ADD(1)="",(ADD(2)=""),(ADD(3)=""),(ADD(6)="") S ERROR=8,NM=$$NAM^RCFN01(+PT) D ERROR S ^TMP($J,"ERRPT",+PT)="" Q
  1. I ADD(4)=""!(ADD(5)="")!(ADD(6)="") S ERROR=8,NM=$$NAM^RCFN01(+PT) D ERROR S ^TMP($J,"ERRPT",+PT)=""
  1. F ADD=1:1:6 I ADD(ADD)'?.ANP S ERROR=10,NM=$$NAM^RCFN01(+PT),^TMP($J,"ERRPT",+PT)="" D ERROR Q
  1. I $P($G(^RCD(340,+PT,1)),"^",9) S ^TMP($J,"ERRPT",+PT)="",ERROR=9,NM=$$NAM^RCFN01(+PT) D ERROR
  1. Q