RCEVDRV1 ;WASH-ISC@ALTOONA,PA/RGY-Add event to enter file driver #1 ;7/7/95 11:01 AM
V ;;4.5;Accounts Receivable;**10**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
OPEN(TYPE,DEB,DOE,RCDUZ,SITE,ERROR,EVN,BAL) ;Add new event to event file
NEW DIC,D0,DIE,DA,X,DLAYGO,DR,DEBT,EVENT,DIS,RCOK
S DEBT=$$DEBT^RCEVUTL(DEB),ERROR="",EVN=-1
I DEBT<0 S ERROR="Unable to locate or add Debtor '"_DEB_"' (PRCADRV1)" G Q
I $O(^RC(341,"AC",DEBT,0,0)) S EVN=0 F S EVN=$O(^RC(341,"AC",DEBT,0,EVN)) Q:EVN="" D DEL(EVN)
F EVN=+$P(^RC(341,0),"^",3)+1:1 L +^RC(341,EVN):0 I $T S RCOK=0 D L -^RC(341,EVN) Q:RCOK
.I $D(^RC(341,EVN)) Q
.S DINUM=EVN,DIC="^RC(341,",DIC(0)="L",DLAYGO=341,X=SITE_"-"_EVN_"-0" K DD,DO D FILE^DICN K DIC,DLAYGO,DO
.S DIE="^RC(341,",DR="[RCEV OPEN EVENT]",DA=EVN D ^DIE
.S RCOK=1
.Q
Q Q
CLOSE(EVN,ERR) ;Close event
S DIE="^RC(341,",DR="[RCEV CLOSE EVENT]",DA=EVN D ^DIE
Q
DEL(EVN) ;Delete event
NEW DIK,DA
I $P($G(^RC(341,EVN,0)),"^",11)=1 G Q2
S DA=EVN,DIK="^RC(341," D ^DIK
Q2 Q
PUR ;Purge events
NEW DATE,EVN,EVN2,DEBT,LST,N0,PURDT
S DATE=0,EVN2=""
F S DATE=$O(^RC(341,"C",DATE)) Q:'DATE S EVN=0 F S EVN=$O(^RC(341,"C",DATE,EVN)) Q:'EVN D
.S N0=$G(^RC(341,EVN,0)) Q:N0=""
.S DEBT=$P(N0,"^",5) Q:DEBT=""
.S LST=$O(^RC(341,"AD",DEBT,2,"")) Q:LST=""
.S PURDT=$O(^RC(341,"AD",DEBT,2,LST)) Q:PURDT=""
.S EVN2=$O(^RC(341,"AD",DEBT,2,PURDT,EVN2)) Q:EVN2=""!(EVN=EVN2)
.S PURDT=9999999.999999-PURDT
.Q:DATE>PURDT
.I $P(N0,"^",7)<PURDT,$P(N0,"^",2)'=$O(^RC(341.1,"AC",1,0)),EVN'=$P($$LST^RCFN01($P(N0,"^",5),2),"^",2) S DA=EVN,DIK="^RC(341," D ^DIK
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCEVDRV1 1660 printed Apr 09, 2024@20:52:15 Page 2
RCEVDRV1 ;WASH-ISC@ALTOONA,PA/RGY-Add event to enter file driver #1 ;7/7/95 11:01 AM
V ;;4.5;Accounts Receivable;**10**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
OPEN(TYPE,DEB,DOE,RCDUZ,SITE,ERROR,EVN,BAL) ;Add new event to event file
+1 NEW DIC,D0,DIE,DA,X,DLAYGO,DR,DEBT,EVENT,DIS,RCOK
+2 SET DEBT=$$DEBT^RCEVUTL(DEB)
SET ERROR=""
SET EVN=-1
+3 IF DEBT<0
SET ERROR="Unable to locate or add Debtor '"_DEB_"' (PRCADRV1)"
GOTO Q
+4 IF $ORDER(^RC(341,"AC",DEBT,0,0))
SET EVN=0
FOR
SET EVN=$ORDER(^RC(341,"AC",DEBT,0,EVN))
if EVN=""
QUIT
DO DEL(EVN)
+5 FOR EVN=+$PIECE(^RC(341,0),"^",3)+1:1
LOCK +^RC(341,EVN):0
IF $TEST
SET RCOK=0
Begin DoDot:1
+6 IF $DATA(^RC(341,EVN))
QUIT
+7 SET DINUM=EVN
SET DIC="^RC(341,"
SET DIC(0)="L"
SET DLAYGO=341
SET X=SITE_"-"_EVN_"-0"
KILL DD,DO
DO FILE^DICN
KILL DIC,DLAYGO,DO
+8 SET DIE="^RC(341,"
SET DR="[RCEV OPEN EVENT]"
SET DA=EVN
DO ^DIE
+9 SET RCOK=1
+10 QUIT
End DoDot:1
LOCK -^RC(341,EVN)
if RCOK
QUIT
Q QUIT
CLOSE(EVN,ERR) ;Close event
+1 SET DIE="^RC(341,"
SET DR="[RCEV CLOSE EVENT]"
SET DA=EVN
DO ^DIE
+2 QUIT
DEL(EVN) ;Delete event
+1 NEW DIK,DA
+2 IF $PIECE($GET(^RC(341,EVN,0)),"^",11)=1
GOTO Q2
+3 SET DA=EVN
SET DIK="^RC(341,"
DO ^DIK
Q2 QUIT
PUR ;Purge events
+1 NEW DATE,EVN,EVN2,DEBT,LST,N0,PURDT
+2 SET DATE=0
SET EVN2=""
+3 FOR
SET DATE=$ORDER(^RC(341,"C",DATE))
if 'DATE
QUIT
SET EVN=0
FOR
SET EVN=$ORDER(^RC(341,"C",DATE,EVN))
if 'EVN
QUIT
Begin DoDot:1
+4 SET N0=$GET(^RC(341,EVN,0))
if N0=""
QUIT
+5 SET DEBT=$PIECE(N0,"^",5)
if DEBT=""
QUIT
+6 SET LST=$ORDER(^RC(341,"AD",DEBT,2,""))
if LST=""
QUIT
+7 SET PURDT=$ORDER(^RC(341,"AD",DEBT,2,LST))
if PURDT=""
QUIT
+8 SET EVN2=$ORDER(^RC(341,"AD",DEBT,2,PURDT,EVN2))
if EVN2=""!(EVN=EVN2)
QUIT
+9 SET PURDT=9999999.999999-PURDT
+10 if DATE>PURDT
QUIT
+11 IF $PIECE(N0,"^",7)<PURDT
IF $PIECE(N0,"^",2)'=$ORDER(^RC(341.1,"AC",1,0))
IF EVN'=$PIECE($$LST^RCFN01($PIECE(N0,"^",5),2),"^",2)
SET DA=EVN
SET DIK="^RC(341,"
DO ^DIK
+12 QUIT
End DoDot:1
+13 QUIT
