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