PRCALT2 ;WASH-ISC@ALTOONA,PA/RGY-PRINT COLLECTION LETTER UB-82 ;2/28/95 10:44 AM
V ;;4.5;Accounts Receivable;**48**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
NEW DEB,STAT,PRCABN,PRCA,PRCASV,EVN,ERR,DA,DIE
S STAT=$O(^PRCA(430.3,"AC",102,0))
F DEB=0:0 S DEB=$O(^RCD(340,"AB","DIC(36,",DEB)) Q:'DEB F PRCABN=0:0 S PRCABN=$O(^PRCA(430,"AS",DEB,STAT,PRCABN)) Q:'PRCABN D CHK
Q
CHK I "^21^35^37^39^"'[("^"_$P($G(^PRCA(430.2,+$P($G(^PRCA(430,PRCABN,0)),"^",2),0)),U,7)_"^") G Q
I $G(^PRCA(430,PRCABN,1)) G Q
S PRCA7=$G(^PRCA(430,PRCABN,7))
I $P(PRCA7,U)+$P(PRCA7,U,2)+$P(PRCA7,U,3)+$P(PRCA7,U,4)+$P(PRCA7,U,5)<1 G Q
I $P(^PRCA(430,PRCABN,0),U,8)'=STAT G Q
L1 I "^21^35^37^39^"'[("^"_$P(^PRCA(430.2,+$P($G(^PRCA(430,PRCABN,0)),"^",2),0),"^",7)_"^") G Q
I '$G(^PRCA(430,PRCABN,6)) D G Q
.D OPEN^RCEVDRV1(9,$P(^RCD(340,DEB,0),"^"),DT,DUZ,$$SITE^RCMSITE(),.ERR,.EVN,$P($G(^PRCA(430,PRCABN,7)),"^",1,5)) Q:ERR]""
.S $P(^PRCA(430,PRCABN,6),"^")=DT,$P(^(6),"^",9)=DT
.S DIE="^RC(341,",DA=EVN,DR="5.01////^S X="_PRCABN_";5.02////^S X=1" D ^DIE
.D CLOSE^RCEVDRV1(EVN,.ERR) I ERR]"" D DEL^RCEVDRV1(EVN)
.Q
I $P(^PRCA(430,PRCABN,6),U,4) G Q
L2 I '$P(^PRCA(430,PRCABN,6),U,2) D G Q
.S X1=DT,X2=$P(^PRCA(430,PRCABN,6),U,1) D ^%DTC Q:X<45
.D OPEN^RCEVDRV1(9,$P(^RCD(340,DEB,0),"^"),DT,DUZ,$$SITE^RCMSITE(),.ERR,.EVN,$P($G(^PRCA(430,PRCABN,7)),"^",1,5)) Q:ERR]""
.S PRCASV("ARREC")=PRCABN,PRCASV("NOTICE")=2 D REPRNT^IBCF13 Q:'IBAR("OKAY")
.S $P(^PRCA(430,PRCABN,6),U,2)=DT,$P(^(6),"^",9)=DT
.S DIE="^RC(341,",DA=EVN,DR="5.01////^S X="_PRCABN_";5.02////^S X=2" D ^DIE
.D CLOSE^RCEVDRV1(EVN,.ERR) I ERR]"" D DEL^RCEVDRV1(EVN)
.Q
L3 I '$P(^PRCA(430,PRCABN,6),"^",3) D
.S X1=DT,X2=$P(^PRCA(430,PRCABN,6),U,2) D ^%DTC Q:X<30
.D OPEN^RCEVDRV1(9,$P(^RCD(340,DEB,0),"^"),DT,DUZ,$$SITE^RCMSITE(),.ERR,.EVN,$P($G(^PRCA(430,PRCABN,7)),"^",1,5)) Q:ERR]""
.S PRCASV("ARREC")=PRCABN,PRCASV("NOTICE")=3 D REPRNT^IBCF13 Q:'IBAR("OKAY")
.S $P(^PRCA(430,PRCABN,6),U,3)=DT,$P(^(6),"^",9)=DT
.S DIE="^RC(341,",DA=EVN,DR="5.01////^S X="_PRCABN_";5.02////^S X=3" D ^DIE
.D CLOSE^RCEVDRV1(EVN,.ERR) I ERR]"" D DEL^RCEVDRV1(EVN)
.Q
Q Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCALT2 2202 printed Dec 13, 2024@01:40:20 Page 2
PRCALT2 ;WASH-ISC@ALTOONA,PA/RGY-PRINT COLLECTION LETTER UB-82 ;2/28/95 10:44 AM
V ;;4.5;Accounts Receivable;**48**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW DEB,STAT,PRCABN,PRCA,PRCASV,EVN,ERR,DA,DIE
+3 SET STAT=$ORDER(^PRCA(430.3,"AC",102,0))
+4 FOR DEB=0:0
SET DEB=$ORDER(^RCD(340,"AB","DIC(36,",DEB))
if 'DEB
QUIT
FOR PRCABN=0:0
SET PRCABN=$ORDER(^PRCA(430,"AS",DEB,STAT,PRCABN))
if 'PRCABN
QUIT
DO CHK
+5 QUIT
CHK IF "^21^35^37^39^"'[("^"_$PIECE($GET(^PRCA(430.2,+$PIECE($GET(^PRCA(430,PRCABN,0)),"^",2),0)),U,7)_"^")
GOTO Q
+1 IF $GET(^PRCA(430,PRCABN,1))
GOTO Q
+2 SET PRCA7=$GET(^PRCA(430,PRCABN,7))
+3 IF $PIECE(PRCA7,U)+$PIECE(PRCA7,U,2)+$PIECE(PRCA7,U,3)+$PIECE(PRCA7,U,4)+$PIECE(PRCA7,U,5)<1
GOTO Q
+4 IF $PIECE(^PRCA(430,PRCABN,0),U,8)'=STAT
GOTO Q
L1 IF "^21^35^37^39^"'[("^"_$PIECE(^PRCA(430.2,+$PIECE($GET(^PRCA(430,PRCABN,0)),"^",2),0),"^",7)_"^")
GOTO Q
+1 IF '$GET(^PRCA(430,PRCABN,6))
Begin DoDot:1
+2 DO OPEN^RCEVDRV1(9,$PIECE(^RCD(340,DEB,0),"^"),DT,DUZ,$$SITE^RCMSITE(),.ERR,.EVN,$PIECE($GET(^PRCA(430,PRCABN,7)),"^",1,5))
if ERR]""
QUIT
+3 SET $PIECE(^PRCA(430,PRCABN,6),"^")=DT
SET $PIECE(^(6),"^",9)=DT
+4 SET DIE="^RC(341,"
SET DA=EVN
SET DR="5.01////^S X="_PRCABN_";5.02////^S X=1"
DO ^DIE
+5 DO CLOSE^RCEVDRV1(EVN,.ERR)
IF ERR]""
DO DEL^RCEVDRV1(EVN)
+6 QUIT
End DoDot:1
GOTO Q
+7 IF $PIECE(^PRCA(430,PRCABN,6),U,4)
GOTO Q
L2 IF '$PIECE(^PRCA(430,PRCABN,6),U,2)
Begin DoDot:1
+1 SET X1=DT
SET X2=$PIECE(^PRCA(430,PRCABN,6),U,1)
DO ^%DTC
if X<45
QUIT
+2 DO OPEN^RCEVDRV1(9,$PIECE(^RCD(340,DEB,0),"^"),DT,DUZ,$$SITE^RCMSITE(),.ERR,.EVN,$PIECE($GET(^PRCA(430,PRCABN,7)),"^",1,5))
if ERR]""
QUIT
+3 SET PRCASV("ARREC")=PRCABN
SET PRCASV("NOTICE")=2
DO REPRNT^IBCF13
if 'IBAR("OKAY")
QUIT
+4 SET $PIECE(^PRCA(430,PRCABN,6),U,2)=DT
SET $PIECE(^(6),"^",9)=DT
+5 SET DIE="^RC(341,"
SET DA=EVN
SET DR="5.01////^S X="_PRCABN_";5.02////^S X=2"
DO ^DIE
+6 DO CLOSE^RCEVDRV1(EVN,.ERR)
IF ERR]""
DO DEL^RCEVDRV1(EVN)
+7 QUIT
End DoDot:1
GOTO Q
L3 IF '$PIECE(^PRCA(430,PRCABN,6),"^",3)
Begin DoDot:1
+1 SET X1=DT
SET X2=$PIECE(^PRCA(430,PRCABN,6),U,2)
DO ^%DTC
if X<30
QUIT
+2 DO OPEN^RCEVDRV1(9,$PIECE(^RCD(340,DEB,0),"^"),DT,DUZ,$$SITE^RCMSITE(),.ERR,.EVN,$PIECE($GET(^PRCA(430,PRCABN,7)),"^",1,5))
if ERR]""
QUIT
+3 SET PRCASV("ARREC")=PRCABN
SET PRCASV("NOTICE")=3
DO REPRNT^IBCF13
if 'IBAR("OKAY")
QUIT
+4 SET $PIECE(^PRCA(430,PRCABN,6),U,3)=DT
SET $PIECE(^(6),"^",9)=DT
+5 SET DIE="^RC(341,"
SET DA=EVN
SET DR="5.01////^S X="_PRCABN_";5.02////^S X=3"
DO ^DIE
+6 DO CLOSE^RCEVDRV1(EVN,.ERR)
IF ERR]""
DO DEL^RCEVDRV1(EVN)
+7 QUIT
End DoDot:1
Q QUIT
