- RCRCREC3 ;ALB/CMS - PARSE RC/AR DATA FOR RECONCILIATION
- V ;;4.5;Accounts Receivable;**63,122**;Mar 20, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- Q
- L433 ;LOOP THRU 433 TO SEE IF BILL WAS DECREASE BEFORE REFERRED
- ;INPUT: BN,MTYP=4,ARLN RCBDT - RCEDT REFERRAL DATE RANGE
- ;QUIT IF BILL REFERRAL DATE NOT IN USER INPUT RANGE
- N TN,TNLN,TNTYP K ERR
- S REFDT=$P(ARLN,U,3)
- I $G(RCBDT)>0,$G(RCEDT)>0 I (REFDT<RCBDT)!(REFDT>RCEDT) G L433Q
- S TN=0 F S TN=$O(^PRCA(433,"C",BN,TN)) Q:('TN)!($O(ERR("MR4",0))) D
- .S TNLN=$G(^PRCA(433,TN,1))
- .I TNLN="" Q
- .S TNTYP=$P(TNLN,U,2) I TNTYP'=35 Q
- .I $P(TNLN,U,1)'>REFDT D
- ..I +$P($G(^PRCA(433,TN,8)),U,8) S ERR("MR4",4)="" Q
- ..S ERR("MR4",11)=""
- L433Q Q
- ;
- SET ;SET TMP WITH THE MESSAGE TYPE PER BILL
- N ERRLN,ERRN,LN,LT,REFDT,X,Y
- N SPBN,SPPT,SPIN S LN=0
- I $G(ARLN)="" G SETB
- S (SPBN,SPPT,SPIN)="",LN=LN+1
- I $P(ARLN,U,1)="" S $P(ARLN,U,1)="UNK"
- I $P(RCLN,U,1)="" S $P(RCLN,U,1)="UNK"
- S Y=$P(ARLN,U,3) D D^DIQ S REFDT=Y
- I $L(REFDT)<10 S $E(REFDT,11)=" "
- I $L(REFDT)=10 S REFDT=REFDT_" "
- S $E(SPBN,(11-$L($E($P(ARLN,U,1),1,11))))=" "
- S $E(SPPT,(15-$L($E($P(ARLN,U,5),1,15))))=" "
- S $E(SPIN,(15-$L($E($P(ARLN,U,2),1,15))))=" "
- ;S LN=+^TMP("PRCA",$J,MTYP,0)
- ;S LN=LN+1,^TMP("PRCA",$J,MTYP,LN)=" "
- ;S LN=LN+1
- S ^TMP("PRCA",$J,"B",MTYP,$S($P($G(ARLN),U,8)]"":$P($G(ARLN),U,8),1:"CAT/UNK"),$S($P(ARLN,U,2)]"":$P(ARLN,U,2),1:"UNK"),$S($P(ARLN,U,5)]"":$P(ARLN,U,5),1:"UNK"),$P(ARLN,U,1))=""
- S ^TMP("PRCA",$J,"C",$P(ARLN,U,1),LN)="AR:"_$P(ARLN,U,1)_$G(SPBN)_" "_$E($P(ARLN,U,5),1,15)_$G(SPPT)_" "_$E($P(ARLN,U,2),1,15)_$G(SPIN)_" "_$S($P(ARLN,U,4)="DC":"RC ",1:$P(ARLN,U,4))_" "_REFDT_" $"_$J($P(ARLN,U,6),10,2)
- ;
- SETB I $G(RCLN)="" G SETC
- S (SPBN,SPPT,SPIN)="",LN=LN+1
- S Y=$P(RCLN,U,3) D D^DIQ S REFDT=Y
- I $L(REFDT)<10 S $E(REFDT,11)=" "
- I $L(REFDT)=10 S REFDT=REFDT_" "
- S $E(SPBN,(11-$L($E($P(RCLN,U,1),1,11))))=" "
- S $E(SPPT,(15-$L($E($P(RCLN,U,5),1,15))))=" "
- S $E(SPIN,(15-$L($E($P(RCLN,U,2),1,15))))=" "
- ;S LN=+^TMP("PRCA",$J,MTYP,0)
- ;S LN=LN+1,^TMP("PRCA",$J,MTYP,LN)=" "
- ;S LN=LN+1
- I $G(ARLN)="" D
- .S ^TMP("PRCA",$J,"B",MTYP,$S($P(RCLN,U,8)]"":$P(RCLN,U,8),1:"CAT/UNK"),$S($P(RCLN,U,2)]"":$P(RCLN,U,2),1:"UNK"),$S($P(RCLN,U,5)]"":$P(RCLN,U,5),1:"UNK"),$S($P(RCLN,U,1)]"":$P(RCLN,U),1:"UNK"))=""
- S ^TMP("PRCA",$J,"C",$S($P(RCLN,U,1)]"":$P(RCLN,U),1:"UNK"),LN)="RC:"_$P(RCLN,U,1)_$G(SPBN)_" "_$E($P(RCLN,U,5),1,15)_$G(SPPT)_" "_$E($P(RCLN,U,2),1,15)_$G(SPIN)_" RC "_REFDT_" $"_$J($P(RCLN,U,6),10,2)
- ;
- SETC S ERRN=0 F S ERRN=$O(ERR(MTYP,ERRN)) Q:'ERRN D
- .S LT="ARR",ERRLN=$T(@LT+ERRN),LN=LN+1
- .S ^TMP("PRCA",$J,"C",$S($P($G(ARLN),U,1)]"":$P(ARLN,U,1),$P($G(RCLN),U,1)]"":$P(RCLN,U,1),1:"UNK"),LN)=" - "_$P(ERRLN,";",4)_" "_$G(ERR(MTYP,ERRN))
- ;S ^TMP("PRCA",$J,MTYP,0)=LN
- SETQ Q
- ;
- SORT ;Set Global for Mail Message
- N A,B,C,D,E,LN,RCA,RCB,RCBSP,RCC,RCD,RCE,X,Y
- F X=1:1:19 S RCBSP=$G(RCBSP)_" "
- S RCA="" F A=1:1 S RCA=$O(^TMP("PRCA",$J,"B",RCA)) Q:RCA="" D
- .S LN=^TMP("PRCA",$J,RCA,0)
- .S RCB="" F B=1:1 S RCB=$O(^TMP("PRCA",$J,"B",RCA,RCB)) Q:RCB="" D
- ..S LN=LN+1,^TMP("PRCA",$J,RCA,LN)="REIMBURS.HEALTH INS."_RCBSP_"Referred To Date Amount"
- ..S LN=LN+1,^TMP("PRCA",$J,RCA,LN)=" "
- ..S RCC="" F C=1:1 S RCC=$O(^TMP("PRCA",$J,"B",RCA,RCB,RCC)) Q:RCC="" D
- ...S RCD="" F D=1:1 S RCD=$O(^TMP("PRCA",$J,"B",RCA,RCB,RCC,RCD)) Q:RCD="" D
- ....S RCE="" F E=1:1 S RCE=$O(^TMP("PRCA",$J,"B",RCA,RCB,RCC,RCD,RCE)) Q:RCE="" D
- .....S LN=LN+1,^TMP("PRCA",$J,RCA,LN)=" "
- .....S X=0 F S X=$O(^TMP("PRCA",$J,"C",RCE,X)) Q:'X D
- ......S LN=LN+1,^TMP("PRCA",$J,RCA,LN)=^TMP("PRCA",$J,"C",RCE,X)
- ......S ^TMP("PRCA",$J,RCA,0)=LN
- SORTQ Q
- ;
- ARR ;GET DATA FOR ERROR TYPES
- ;;1;BILL NAME DOES NOT EXIST IN ACCOUNTS RECEIVABLE
- ;;2;NON-ACTIVE BILL AT SITE, CURRENT AR BILL STATUS IS
- ;;3;DOLLAR AMOUNTS NOT THE SAME
- ;;4;CONTRACTUAL/DECREASE ADJUSTMENT WAS MADE IN AR BEFORE REFERRAL DATE
- ;;5;NO REFERRAL DATE IN THE AR ACCOUNTS RECEIVABLE FILE
- ;;6;AR BILL CATEGORY IS
- ;;7;SITE PROBLEM, AR REF.AMT DOES NOT MATCH AR CURRENT BALANCE OF $
- ;;8;NOT IN USE
- ;;9;BILL SSN FOR PT. IN AR DOES NOT MATCH SSN FOR PT. IN RC
- ;;10;NOT IN USE
- ;;11;DECREASE ADJUSTMENT WAS MADE IN AR BEFORE THE REFERRAL DATE
- ;;END
- Q
- ;RCRCREC3
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRCREC3 4343 printed Feb 18, 2025@23:14:07 Page 2
- RCRCREC3 ;ALB/CMS - PARSE RC/AR DATA FOR RECONCILIATION
- V ;;4.5;Accounts Receivable;**63,122**;Mar 20, 1995
- +1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- +3 QUIT
- L433 ;LOOP THRU 433 TO SEE IF BILL WAS DECREASE BEFORE REFERRED
- +1 ;INPUT: BN,MTYP=4,ARLN RCBDT - RCEDT REFERRAL DATE RANGE
- +2 ;QUIT IF BILL REFERRAL DATE NOT IN USER INPUT RANGE
- +3 NEW TN,TNLN,TNTYP
- KILL ERR
- +4 SET REFDT=$PIECE(ARLN,U,3)
- +5 IF $GET(RCBDT)>0
- IF $GET(RCEDT)>0
- IF (REFDT<RCBDT)!(REFDT>RCEDT)
- GOTO L433Q
- +6 SET TN=0
- FOR
- SET TN=$ORDER(^PRCA(433,"C",BN,TN))
- if ('TN)!($ORDER(ERR("MR4",0)))
- QUIT
- Begin DoDot:1
- +7 SET TNLN=$GET(^PRCA(433,TN,1))
- +8 IF TNLN=""
- QUIT
- +9 SET TNTYP=$PIECE(TNLN,U,2)
- IF TNTYP'=35
- QUIT
- +10 IF $PIECE(TNLN,U,1)'>REFDT
- Begin DoDot:2
- +11 IF +$PIECE($GET(^PRCA(433,TN,8)),U,8)
- SET ERR("MR4",4)=""
- QUIT
- +12 SET ERR("MR4",11)=""
- End DoDot:2
- End DoDot:1
- L433Q QUIT
- +1 ;
- SET ;SET TMP WITH THE MESSAGE TYPE PER BILL
- +1 NEW ERRLN,ERRN,LN,LT,REFDT,X,Y
- +2 NEW SPBN,SPPT,SPIN
- SET LN=0
- +3 IF $GET(ARLN)=""
- GOTO SETB
- +4 SET (SPBN,SPPT,SPIN)=""
- SET LN=LN+1
- +5 IF $PIECE(ARLN,U,1)=""
- SET $PIECE(ARLN,U,1)="UNK"
- +6 IF $PIECE(RCLN,U,1)=""
- SET $PIECE(RCLN,U,1)="UNK"
- +7 SET Y=$PIECE(ARLN,U,3)
- DO D^DIQ
- SET REFDT=Y
- +8 IF $LENGTH(REFDT)<10
- SET $EXTRACT(REFDT,11)=" "
- +9 IF $LENGTH(REFDT)=10
- SET REFDT=REFDT_" "
- +10 SET $EXTRACT(SPBN,(11-$LENGTH($EXTRACT($PIECE(ARLN,U,1),1,11))))=" "
- +11 SET $EXTRACT(SPPT,(15-$LENGTH($EXTRACT($PIECE(ARLN,U,5),1,15))))=" "
- +12 SET $EXTRACT(SPIN,(15-$LENGTH($EXTRACT($PIECE(ARLN,U,2),1,15))))=" "
- +13 ;S LN=+^TMP("PRCA",$J,MTYP,0)
- +14 ;S LN=LN+1,^TMP("PRCA",$J,MTYP,LN)=" "
- +15 ;S LN=LN+1
- +16 SET ^TMP("PRCA",$JOB,"B",MTYP,$SELECT($PIECE($GET(ARLN),U,8)]"":$PIECE($GET(ARLN),U,8),1:"CAT/UNK"),$SELECT($PIECE(ARLN,U,2)]"":$PIECE(ARLN,U,2),1:"UNK"),$SELECT($PIECE(ARLN,U,5)]"":$PIECE(ARLN,U,5),1:"UNK"),$PIECE(ARLN,U,1))=""
- +17 SET ^TMP("PRCA",$JOB,"C",$PIECE(ARLN,U,1),LN)="AR:"_$PIECE(ARLN,U,1)_$GET(SPBN)_" "_$EXTRACT($PIECE(ARLN,U,5),1,15)_$GET(SPPT)_" "_$EXTRACT(...
- ... $PIECE(ARLN,U,2),1,15)_$GET(SPIN)_" "_$SELECT($PIECE(ARLN,U,4)="DC":"RC ",1:$PIECE(ARLN,U,4))_" "_REFDT_" $"_$JUSTIFY($PIECE(ARLN,U,6),10,2)
- +18 ;
- SETB IF $GET(RCLN)=""
- GOTO SETC
- +1 SET (SPBN,SPPT,SPIN)=""
- SET LN=LN+1
- +2 SET Y=$PIECE(RCLN,U,3)
- DO D^DIQ
- SET REFDT=Y
- +3 IF $LENGTH(REFDT)<10
- SET $EXTRACT(REFDT,11)=" "
- +4 IF $LENGTH(REFDT)=10
- SET REFDT=REFDT_" "
- +5 SET $EXTRACT(SPBN,(11-$LENGTH($EXTRACT($PIECE(RCLN,U,1),1,11))))=" "
- +6 SET $EXTRACT(SPPT,(15-$LENGTH($EXTRACT($PIECE(RCLN,U,5),1,15))))=" "
- +7 SET $EXTRACT(SPIN,(15-$LENGTH($EXTRACT($PIECE(RCLN,U,2),1,15))))=" "
- +8 ;S LN=+^TMP("PRCA",$J,MTYP,0)
- +9 ;S LN=LN+1,^TMP("PRCA",$J,MTYP,LN)=" "
- +10 ;S LN=LN+1
- +11 IF $GET(ARLN)=""
- Begin DoDot:1
- +12 SET ^TMP("PRCA",$JOB,"B",MTYP,$SELECT($PIECE(RCLN,U,8)]"":$PIECE(RCLN,U,8),1:"CAT/UNK"),$SELECT($PIECE(RCLN,U,2)]"":$PIECE(RCLN,U,2),1:"UNK"),$SELECT($PIECE(RCLN,U,5)]"":$PIECE(RCLN,U,5),1:"UNK"),$SELECT($PIECE(RCLN,U,1)]"":$PIECE(RCLN,
- U),1:"UNK"))=""
- End DoDot:1
- +13 SET ^TMP("PRCA",$JOB,"C",$SELECT($PIECE(RCLN,U,1)]"":$PIECE(RCLN,U),1:"UNK"),LN)="RC:"_$PIECE(RCLN,U,1)_$GET(SPBN)_" "_$EXTRACT($PIECE(RCLN,U,5),1,15)_$GET(SPPT)_" "_$EXTRACT($PIECE(RCLN,U,2),1,15)_...
- ... $GET(SPIN)_" RC "_REFDT_" $"_$JUSTIFY($PIECE(RCLN,U,6),10,2)
- +14 ;
- SETC SET ERRN=0
- FOR
- SET ERRN=$ORDER(ERR(MTYP,ERRN))
- if 'ERRN
- QUIT
- Begin DoDot:1
- +1 SET LT="ARR"
- SET ERRLN=$TEXT(@LT+ERRN)
- SET LN=LN+1
- +2 SET ^TMP("PRCA",$JOB,"C",$SELECT($PIECE($GET(ARLN),U,1)]"":$PIECE(ARLN,U,1),$PIECE($GET(RCLN),U,1)]"":$PIECE(RCLN,U,1),1:"UNK"),LN)=" - "_$PIECE(ERRLN,";",4)_" "_$GET(ERR(MTYP,ERRN))
- End DoDot:1
- +3 ;S ^TMP("PRCA",$J,MTYP,0)=LN
- SETQ QUIT
- +1 ;
- SORT ;Set Global for Mail Message
- +1 NEW A,B,C,D,E,LN,RCA,RCB,RCBSP,RCC,RCD,RCE,X,Y
- +2 FOR X=1:1:19
- SET RCBSP=$GET(RCBSP)_" "
- +3 SET RCA=""
- FOR A=1:1
- SET RCA=$ORDER(^TMP("PRCA",$JOB,"B",RCA))
- if RCA=""
- QUIT
- Begin DoDot:1
- +4 SET LN=^TMP("PRCA",$JOB,RCA,0)
- +5 SET RCB=""
- FOR B=1:1
- SET RCB=$ORDER(^TMP("PRCA",$JOB,"B",RCA,RCB))
- if RCB=""
- QUIT
- Begin DoDot:2
- +6 SET LN=LN+1
- SET ^TMP("PRCA",$JOB,RCA,LN)="REIMBURS.HEALTH INS."_RCBSP_"Referred To Date Amount"
- +7 SET LN=LN+1
- SET ^TMP("PRCA",$JOB,RCA,LN)=" "
- +8 SET RCC=""
- FOR C=1:1
- SET RCC=$ORDER(^TMP("PRCA",$JOB,"B",RCA,RCB,RCC))
- if RCC=""
- QUIT
- Begin DoDot:3
- +9 SET RCD=""
- FOR D=1:1
- SET RCD=$ORDER(^TMP("PRCA",$JOB,"B",RCA,RCB,RCC,RCD))
- if RCD=""
- QUIT
- Begin DoDot:4
- +10 SET RCE=""
- FOR E=1:1
- SET RCE=$ORDER(^TMP("PRCA",$JOB,"B",RCA,RCB,RCC,RCD,RCE))
- if RCE=""
- QUIT
- Begin DoDot:5
- +11 SET LN=LN+1
- SET ^TMP("PRCA",$JOB,RCA,LN)=" "
- +12 SET X=0
- FOR
- SET X=$ORDER(^TMP("PRCA",$JOB,"C",RCE,X))
- if 'X
- QUIT
- Begin DoDot:6
- +13 SET LN=LN+1
- SET ^TMP("PRCA",$JOB,RCA,LN)=^TMP("PRCA",$JOB,"C",RCE,X)
- +14 SET ^TMP("PRCA",$JOB,RCA,0)=LN
- End DoDot:6
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- SORTQ QUIT
- +1 ;
- ARR ;GET DATA FOR ERROR TYPES
- +1 ;;1;BILL NAME DOES NOT EXIST IN ACCOUNTS RECEIVABLE
- +2 ;;2;NON-ACTIVE BILL AT SITE, CURRENT AR BILL STATUS IS
- +3 ;;3;DOLLAR AMOUNTS NOT THE SAME
- +4 ;;4;CONTRACTUAL/DECREASE ADJUSTMENT WAS MADE IN AR BEFORE REFERRAL DATE
- +5 ;;5;NO REFERRAL DATE IN THE AR ACCOUNTS RECEIVABLE FILE
- +6 ;;6;AR BILL CATEGORY IS
- +7 ;;7;SITE PROBLEM, AR REF.AMT DOES NOT MATCH AR CURRENT BALANCE OF $
- +8 ;;8;NOT IN USE
- +9 ;;9;BILL SSN FOR PT. IN AR DOES NOT MATCH SSN FOR PT. IN RC
- +10 ;;10;NOT IN USE
- +11 ;;11;DECREASE ADJUSTMENT WAS MADE IN AR BEFORE THE REFERRAL DATE
- +12 ;;END
- +13 QUIT
- +14 ;RCRCREC3