PRCASVC3.m

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 ---PRCASVC3   2054     printed  Apr 23, 2025@17:55:51                                                                                                                                                                                                    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