RCTOPS ;WASH IRMFO@ALTOONA,PA/TJK-DMC 90 DAY (SERVER) ;10/24/96 3:21 PM
V ;;4.5;Accounts Receivable;**141,229**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;Program to process server messages from DMC
;1) Will automatically delete TOP flags from local system for
; those patients submitted to TOP that are rejected by TOP, Austin
; or DMC
;2) Will adjust TOP amount if update rejected
;
READ ;READS MESSAGE INTO TEMPORARY GLOBAL
K ^TMP("RCTOPS",$J) S XMA=0
READ1 X XMREC I $D(XMER) G PROC:XMER<0
S XMA=XMA+1
S ^TMP("RCTOPS",$J,"READ",XMA)=XMRG
G READ1
PROC N DEBTOR,TIN,LN,I,REC,NAME,TYPE,CNTR,BILL,ACTION,ECODE,ECODE1,AMOUNT
N LDOC,REC1,XMDUZ,XMSUB,XMY,XMTEXT,SEQ,TSEQ,MTYPE,FILE
K XMPOS,XMA,XMER,XMREC,XMRG
S (LDOC,LN)=0
F S LN=$O(^TMP("RCTOPS",$J,"READ",LN)) Q:LN="" S REC=$G(^(LN)) Q:$E(REC,1,4)="NNNN" D
.I $E(REC,1,4)="2TPA" Q
.I REC[U S TSEQ=$P(REC,U),SEQ=$P(REC,U,2),MTYPE=$P(REC,U,3),MTYPE=$S(MTYPE["AUST":"(AAC)",MTYPE["TREAS":"(TREASURY)",1:"(DMC)") Q
.I $L(REC)=250 D LDOC Q
.S DEBTOR=+$E(REC,21,34),TYPE=$E(REC,36),ACTION=$E(REC,35),TIN=""
.S ECODE=$E(REC,202,221)
.S:TYPE=1 TIN=$E(REC,37,45),AMOUNT=$E(REC,135,144)_"."_$E(REC,145,146)
.I TIN="" S TIN=$P($G(^RCD(340,DEBTOR,4)),U) I TIN="" D
..S FILE=$$FILE^RCTOPD(^RCD(340,DEBTOR,0))
..S TIN=$$TAXID^RCTOP1(DEBTOR,FILE)
..Q
.K NAME S DIC=340,DR=.01,DA=DEBTOR,DIQ="NAME",DIQ(0)="E" D EN^DIQ1
.;
.; If DEBTOR is not in VistA - Ignore
.Q:'$D(NAME) ;PRCA*4.5*229
.;
.S NAME=NAME(340,DEBTOR,.01,"E"),NAME=$$LJ^XLFSTR(NAME,30)
.S ECODE1=$E(ECODE,1,2)
.F I=3:2 Q:$E(ECODE,I)'?1N S ECODE1=ECODE1_","_$E(ECODE,I,I+1)
SETLN .S ^TMP("RCTOPS",$J,"BUILD",NAME,TYPE)=NAME_" "_TIN_" "_TYPE_" "_ACTION_" "_ECODE1
.I TYPE=1 D
..I ACTION="A" D Q
...K ^RCD(340,DEBTOR,4),^(5),^(6),^RCD(340,"TOP",DEBTOR)
...S BILL=0
...F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL="" K ^PRCA(430,BILL,14)
...Q
..Q:'$D(^RCD(340,"TOP",DEBTOR))
..S:ACTION="I" $P(^(4),U,3)=$P(^RCD(340,DEBTOR,4),U,3)-AMOUNT
..S:ACTION="S" $P(^(4),U,3)=$P(^RCD(340,DEBTOR,4),U,3)+AMOUNT
..Q
.Q
;
MSG ;Send list of rejected documents
G MSG1:LDOC
S ^TMP("RCTOPS",$J,"REC",1)="The following TOP transmissions have been rejected"
S ^TMP("RCTOPS",$J,"REC",2)=""
S ^TMP("RCTOPS",$J,"REC",3)="NAME TIN TYPE ACTION ERROR CODES"
S ^TMP("RCTOPS",$J,"REC",4)="" G SEND
MSG1 S ^TMP("RCTOPS",$J,"REC",1)="The following debtors were unable to have TOP letters sent:"
S ^TMP("RCTOPS",$J,"REC",2)=""
S ^TMP("RCTOPS",$J,"REC",3)="NAME TIN ERROR CODES"
S ^TMP("RCTOPS",$J,"REC",4)=""
SEND D ALPHA
S XMSUB="TOP REJECTS"_MTYPE_" SEQ: "_SEQ_" OF "_TSEQ
S XMY("G.TOP")="",XMDUZ="AR PACKAGE",XMTEXT="^TMP(""RCTOPS"","_$J_",""REC"","
D ^XMD
;
CLEANUP ; This cleans up the ^TMP global.
K ^TMP("RCTOPS",$J)
Q
LDOC ;Process debtor not receiving TOP letters
S:'LDOC LDOC=1
S LN=$O(^TMP("RCTOPS",$J,"READ",LN)) S REC1=^(LN)
S TIN=$E(REC,1,9),DEBTOR=+$E(REC1,104,113),ECODE=$E(REC1,115,134)
K NAME S DIC=340,DR=.01,DA=DEBTOR,DIQ="NAME",DIQ(0)="E" D EN^DIQ1
S NAME=NAME(340,DEBTOR,.01,"E"),NAME=$$LJ^XLFSTR(NAME,40)
S ECODE1=$E(ECODE,1,2)
F I=3:2 Q:$E(ECODE,I)=" " S ECODE1=ECODE1_","_$E(ECODE,I,I+1)
S ^TMP("RCTOPS",$J,"BUILD",NAME,LN)=NAME_" "_TIN_" "_ECODE1
Q
ALPHA ;loads alphabetical listings into "REC"
S NAME="",CNTR=4
F S NAME=$O(^TMP("RCTOPS",$J,"BUILD",NAME)) Q:NAME="" S I=0 D
.F S I=$O(^TMP("RCTOPS",$J,"BUILD",NAME,I)) Q:I'?1N.N S REC=^(I) D
..S CNTR=CNTR+1,^TMP("RCTOPS",$J,"REC",CNTR)=REC
..Q
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTOPS 3830 printed Apr 09, 2024@20:48:06 Page 2
RCTOPS ;WASH IRMFO@ALTOONA,PA/TJK-DMC 90 DAY (SERVER) ;10/24/96 3:21 PM
V ;;4.5;Accounts Receivable;**141,229**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;Program to process server messages from DMC
+3 ;1) Will automatically delete TOP flags from local system for
+4 ; those patients submitted to TOP that are rejected by TOP, Austin
+5 ; or DMC
+6 ;2) Will adjust TOP amount if update rejected
+7 ;
READ ;READS MESSAGE INTO TEMPORARY GLOBAL
+1 KILL ^TMP("RCTOPS",$JOB)
SET XMA=0
READ1 XECUTE XMREC
IF $DATA(XMER)
if XMER<0
GOTO PROC
+1 SET XMA=XMA+1
+2 SET ^TMP("RCTOPS",$JOB,"READ",XMA)=XMRG
+3 GOTO READ1
PROC NEW DEBTOR,TIN,LN,I,REC,NAME,TYPE,CNTR,BILL,ACTION,ECODE,ECODE1,AMOUNT
+1 NEW LDOC,REC1,XMDUZ,XMSUB,XMY,XMTEXT,SEQ,TSEQ,MTYPE,FILE
+2 KILL XMPOS,XMA,XMER,XMREC,XMRG
+3 SET (LDOC,LN)=0
+4 FOR
SET LN=$ORDER(^TMP("RCTOPS",$JOB,"READ",LN))
if LN=""
QUIT
SET REC=$GET(^(LN))
if $EXTRACT(REC,1,4)="NNNN"
QUIT
Begin DoDot:1
+5 IF $EXTRACT(REC,1,4)="2TPA"
QUIT
+6 IF REC[U
SET TSEQ=$PIECE(REC,U)
SET SEQ=$PIECE(REC,U,2)
SET MTYPE=$PIECE(REC,U,3)
SET MTYPE=$SELECT(MTYPE["AUST":"(AAC)",MTYPE["TREAS":"(TREASURY)",1:"(DMC)")
QUIT
+7 IF $LENGTH(REC)=250
DO LDOC
QUIT
+8 SET DEBTOR=+$EXTRACT(REC,21,34)
SET TYPE=$EXTRACT(REC,36)
SET ACTION=$EXTRACT(REC,35)
SET TIN=""
+9 SET ECODE=$EXTRACT(REC,202,221)
+10 if TYPE=1
SET TIN=$EXTRACT(REC,37,45)
SET AMOUNT=$EXTRACT(REC,135,144)_"."_$EXTRACT(REC,145,146)
+11 IF TIN=""
SET TIN=$PIECE($GET(^RCD(340,DEBTOR,4)),U)
IF TIN=""
Begin DoDot:2
+12 SET FILE=$$FILE^RCTOPD(^RCD(340,DEBTOR,0))
+13 SET TIN=$$TAXID^RCTOP1(DEBTOR,FILE)
+14 QUIT
End DoDot:2
+15 KILL NAME
SET DIC=340
SET DR=.01
SET DA=DEBTOR
SET DIQ="NAME"
SET DIQ(0)="E"
DO EN^DIQ1
+16 ;
+17 ; If DEBTOR is not in VistA - Ignore
+18 ;PRCA*4.5*229
if '$DATA(NAME)
QUIT
+19 ;
+20 SET NAME=NAME(340,DEBTOR,.01,"E")
SET NAME=$$LJ^XLFSTR(NAME,30)
+21 SET ECODE1=$EXTRACT(ECODE,1,2)
+22 FOR I=3:2
if $EXTRACT(ECODE,I)'?1N
QUIT
SET ECODE1=ECODE1_","_$EXTRACT(ECODE,I,I+1)
SETLN SET ^TMP("RCTOPS",$JOB,"BUILD",NAME,TYPE)=NAME_" "_TIN_" "_TYPE_" "_ACTION_" "_ECODE1
+1 IF TYPE=1
Begin DoDot:2
+2 IF ACTION="A"
Begin DoDot:3
+3 KILL ^RCD(340,DEBTOR,4),^(5),^(6),^RCD(340,"TOP",DEBTOR)
+4 SET BILL=0
+5 FOR
SET BILL=$ORDER(^PRCA(430,"C",DEBTOR,BILL))
if BILL=""
QUIT
KILL ^PRCA(430,BILL,14)
+6 QUIT
End DoDot:3
QUIT
+7 if '$DATA(^RCD(340,"TOP",DEBTOR))
QUIT
+8 if ACTION="I"
SET $PIECE(^(4),U,3)=$PIECE(^RCD(340,DEBTOR,4),U,3)-AMOUNT
+9 if ACTION="S"
SET $PIECE(^(4),U,3)=$PIECE(^RCD(340,DEBTOR,4),U,3)+AMOUNT
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 ;
MSG ;Send list of rejected documents
+1 if LDOC
GOTO MSG1
+2 SET ^TMP("RCTOPS",$JOB,"REC",1)="The following TOP transmissions have been rejected"
+3 SET ^TMP("RCTOPS",$JOB,"REC",2)=""
+4 SET ^TMP("RCTOPS",$JOB,"REC",3)="NAME TIN TYPE ACTION ERROR CODES"
+5 SET ^TMP("RCTOPS",$JOB,"REC",4)=""
GOTO SEND
MSG1 SET ^TMP("RCTOPS",$JOB,"REC",1)="The following debtors were unable to have TOP letters sent:"
+1 SET ^TMP("RCTOPS",$JOB,"REC",2)=""
+2 SET ^TMP("RCTOPS",$JOB,"REC",3)="NAME TIN ERROR CODES"
+3 SET ^TMP("RCTOPS",$JOB,"REC",4)=""
SEND DO ALPHA
+1 SET XMSUB="TOP REJECTS"_MTYPE_" SEQ: "_SEQ_" OF "_TSEQ
+2 SET XMY("G.TOP")=""
SET XMDUZ="AR PACKAGE"
SET XMTEXT="^TMP(""RCTOPS"","_$JOB_",""REC"","
+3 DO ^XMD
+4 ;
CLEANUP ; This cleans up the ^TMP global.
+1 KILL ^TMP("RCTOPS",$JOB)
+2 QUIT
LDOC ;Process debtor not receiving TOP letters
+1 if 'LDOC
SET LDOC=1
+2 SET LN=$ORDER(^TMP("RCTOPS",$JOB,"READ",LN))
SET REC1=^(LN)
+3 SET TIN=$EXTRACT(REC,1,9)
SET DEBTOR=+$EXTRACT(REC1,104,113)
SET ECODE=$EXTRACT(REC1,115,134)
+4 KILL NAME
SET DIC=340
SET DR=.01
SET DA=DEBTOR
SET DIQ="NAME"
SET DIQ(0)="E"
DO EN^DIQ1
+5 SET NAME=NAME(340,DEBTOR,.01,"E")
SET NAME=$$LJ^XLFSTR(NAME,40)
+6 SET ECODE1=$EXTRACT(ECODE,1,2)
+7 FOR I=3:2
if $EXTRACT(ECODE,I)=" "
QUIT
SET ECODE1=ECODE1_","_$EXTRACT(ECODE,I,I+1)
+8 SET ^TMP("RCTOPS",$JOB,"BUILD",NAME,LN)=NAME_" "_TIN_" "_ECODE1
+9 QUIT
ALPHA ;loads alphabetical listings into "REC"
+1 SET NAME=""
SET CNTR=4
+2 FOR
SET NAME=$ORDER(^TMP("RCTOPS",$JOB,"BUILD",NAME))
if NAME=""
QUIT
SET I=0
Begin DoDot:1
+3 FOR
SET I=$ORDER(^TMP("RCTOPS",$JOB,"BUILD",NAME,I))
if I'?1N.N
QUIT
SET REC=^(I)
Begin DoDot:2
+4 SET CNTR=CNTR+1
SET ^TMP("RCTOPS",$JOB,"REC",CNTR)=REC
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
+7 QUIT
