PRCASVC3 ;WASH-ISC@ALTOONA,PA/RGY-SERVICE BILL CREATOR ;4/27/94 10:09 AM
;;4.5;Accounts Receivable;**158,202,270**;Mar 20, 1995;Build 25
;;Per VHA Directive 2004-038, this routine should not be modified.
;INPUT PRCASV("SITE")=IFCAP site, PRCASV("SER")=Service/Section
;OUTPUT PRCASV("ARREC")=Internal rec. # <OR> -1^Error message
; PRCASV("ARBIL")=Bill # <OR> -1^Error message
;
SETUP ;RETURN THE INTERNAL RECORD NUMBER OF FILE 430
N %,%X,%Y,D,D0,DA,DD,DI,DIC,DICR,DIE,DIG,DIH,DINUM,DIU,DIV,DIW,DLAYGO
N DO,DQ,DR,PRCAP,RCDA,X,Y
;
RTRY ;S (PRCASV("ARBIL"),PRCASV("ARREC"))=-1
; only set to -1 if NOT from new CRD option
S:'$G(PRCASV("ARCRD")) (PRCASV("ARBIL"),PRCASV("ARREC"))=-1
I $S('$D(PRCASV("SITE"))#2:1,'PRCASV("SITE"):1,1:0) D Q
. S PRCASV("ARBIL")="-1^PRCA001"
S DINUM=$S($D(^PRCA(430,0)):$P(^PRCA(430,0),"^",3),1:-1)+1
I 'DINUM S PRCASV("ARREC")="-1^PRCA005" Q
F DINUM=DINUM:1 I '$D(^PRCA(430,DINUM)),'$D(^DGCR(399,DINUM)) L +^PRCA(430,DINUM):1 Q:$T
S RCDA=DINUM,DIC="^PRCA(430,",DIC(0)="QL",DLAYGO=430
; new code for CRD option below
;S (PRCASV("ARBIL"),X)=$$BNUM^RCMSNUM(PRCASV("SITE"))
S:'$G(PRCASV("ARCRD")) (PRCASV("ARBIL"),X)=$$BNUM^RCMSNUM(PRCASV("SITE"))
I $G(PRCASV("ARCRD"))=1 D
.L +^PRCA(430,PRCASV("ARREC")):1 I '$T S X=-1 Q
.S PRCFDA(430,PRCASV("ARREC")_",",.01)=PRCASV("ARITN") D FILE^DIE("","PRCFDA") ; add iteration# to old bill
.L -^PRCA(430,PRCASV("ARREC"))
.S X=PRCASV("ARBIL") ; New bill keeps original #
S DIC="^PRCA(430,",DIC(0)="QL",DLAYGO=430 ; Be sure fileman call above did not reset any variables
; end of new CRD code
I $P(X,"^")=-1 L -^PRCA(430,RCDA) Q
K DD,DO D FILE^DICN
I Y<0 L -^PRCA(430,RCDA) G RTRY
S (PRCASV("ARREC"),DA)=+Y,$P(^PRCA(430,DA,0),U,12)=PRCASV("SITE")
S $P(^PRCA(430,DA,100),U,2)=PRCASV("SER")
I $G(DUZ)!$G(RCDUZ) S $P(^PRCA(430,DA,9),U,8)=$S($G(RCDUZ):RCDUZ,1:DUZ)
S PRCASV("STATUS")=$O(^PRCA(430.3,"AC",201,""))
S DIE="^PRCA(430,",DR="[PRCASV STATUS]" D ^DIE
K PRCASV("STATUS")
L -^PRCA(430,RCDA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCASVC3 2054 printed Oct 16, 2024@17:42:15 Page 2
PRCASVC3 ;WASH-ISC@ALTOONA,PA/RGY-SERVICE BILL CREATOR ;4/27/94 10:09 AM
+1 ;;4.5;Accounts Receivable;**158,202,270**;Mar 20, 1995;Build 25
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;INPUT PRCASV("SITE")=IFCAP site, PRCASV("SER")=Service/Section
+4 ;OUTPUT PRCASV("ARREC")=Internal rec. # <OR> -1^Error message
+5 ; PRCASV("ARBIL")=Bill # <OR> -1^Error message
+6 ;
SETUP ;RETURN THE INTERNAL RECORD NUMBER OF FILE 430
+1 NEW %,%X,%Y,D,D0,DA,DD,DI,DIC,DICR,DIE,DIG,DIH,DINUM,DIU,DIV,DIW,DLAYGO
+2 NEW DO,DQ,DR,PRCAP,RCDA,X,Y
+3 ;
RTRY ;S (PRCASV("ARBIL"),PRCASV("ARREC"))=-1
+1 ; only set to -1 if NOT from new CRD option
+2 if '$GET(PRCASV("ARCRD"))
SET (PRCASV("ARBIL"),PRCASV("ARREC"))=-1
+3 IF $SELECT('$DATA(PRCASV("SITE"))#2:1,'PRCASV("SITE"):1,1:0)
Begin DoDot:1
+4 SET PRCASV("ARBIL")="-1^PRCA001"
End DoDot:1
QUIT
+5 SET DINUM=$SELECT($DATA(^PRCA(430,0)):$PIECE(^PRCA(430,0),"^",3),1:-1)+1
+6 IF 'DINUM
SET PRCASV("ARREC")="-1^PRCA005"
QUIT
+7 FOR DINUM=DINUM:1
IF '$DATA(^PRCA(430,DINUM))
IF '$DATA(^DGCR(399,DINUM))
LOCK +^PRCA(430,DINUM):1
if $TEST
QUIT
+8 SET RCDA=DINUM
SET DIC="^PRCA(430,"
SET DIC(0)="QL"
SET DLAYGO=430
+9 ; new code for CRD option below
+10 ;S (PRCASV("ARBIL"),X)=$$BNUM^RCMSNUM(PRCASV("SITE"))
+11 if '$GET(PRCASV("ARCRD"))
SET (PRCASV("ARBIL"),X)=$$BNUM^RCMSNUM(PRCASV("SITE"))
+12 IF $GET(PRCASV("ARCRD"))=1
Begin DoDot:1
+13 LOCK +^PRCA(430,PRCASV("ARREC")):1
IF '$TEST
SET X=-1
QUIT
+14 ; add iteration# to old bill
SET PRCFDA(430,PRCASV("ARREC")_",",.01)=PRCASV("ARITN")
DO FILE^DIE("","PRCFDA")
+15 LOCK -^PRCA(430,PRCASV("ARREC"))
+16 ; New bill keeps original #
SET X=PRCASV("ARBIL")
End DoDot:1
+17 ; Be sure fileman call above did not reset any variables
SET DIC="^PRCA(430,"
SET DIC(0)="QL"
SET DLAYGO=430
+18 ; end of new CRD code
+19 IF $PIECE(X,"^")=-1
LOCK -^PRCA(430,RCDA)
QUIT
+20 KILL DD,DO
DO FILE^DICN
+21 IF Y<0
LOCK -^PRCA(430,RCDA)
GOTO RTRY
+22 SET (PRCASV("ARREC"),DA)=+Y
SET $PIECE(^PRCA(430,DA,0),U,12)=PRCASV("SITE")
+23 SET $PIECE(^PRCA(430,DA,100),U,2)=PRCASV("SER")
+24 IF $GET(DUZ)!$GET(RCDUZ)
SET $PIECE(^PRCA(430,DA,9),U,8)=$SELECT($GET(RCDUZ):RCDUZ,1:DUZ)
+25 SET PRCASV("STATUS")=$ORDER(^PRCA(430.3,"AC",201,""))
+26 SET DIE="^PRCA(430,"
SET DR="[PRCASV STATUS]"
DO ^DIE
+27 KILL PRCASV("STATUS")
+28 LOCK -^PRCA(430,RCDA)
+29 QUIT
