- 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 Feb 18, 2025@23:09:34 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