- PRCAUTL ;SF-ISC/YJK-AR UTILITY ROUTINES ;8/16/95 11:41 AM
- ;;4.5;Accounts Receivable;**20,34,88,198,236**;Mar 20, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- SETTR ;Set a new transaction number. Return PRCAEN,X,DA
- F DINUM=$P(^PRCA(433,0),"^",3)+1:1 I '$D(^PRCA(433,DINUM)) L +^PRCA(433,DINUM):1 Q:$T
- S RCDA=DINUM,DIC="^PRCA(433,",DIC(0)="L",DLAYGO=433,X=DINUM K DD,DO D FILE^DICN L -^PRCA(433,RCDA) K RCDA,DIC,DINUM,DLAYGO,DO G:Y<0 SETTR
- S (PRCAEN,DA)=+Y,$P(^PRCA(433,PRCAEN,0),U,8)=$S($D(PRCA("APPR")):PRCA("APPR"),1:"")
- S $P(^PRCA(433,PRCAEN,0),U,9)=DUZ
- Q
- BILL ;Look up a bill number - return PRCABN
- K DIC,DA
- BILLN N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
- W ! K PRCABN S DIC="^PRCA(430,",DIC(0)="AEQMZ" D ^DIC G:Y<0 EXIT S PRCABN=+Y,PRCATY=$P(^PRCA(430,PRCABN,0),U,2),PRCA("SEG")=$S(+$P(^(0),U,21)>240:$P(^(0),U,21),1:"")
- S PRCA("STATUS")=$P(^PRCA(430,PRCABN,0),U,8),PRCA("APPR")=$P(^(0),U,18)
- EXIT K DIC Q
- ;
- DEBTOR ;Check a debtor name,active address and other debtor's info.
- ;Return the name and address - PRCA("DEBTNM"),PRCAST1,PRCAST2,PRCACT,PRCAST,PRCAKP.
- D DEBNAM Q:PRCADBPT="" D DEBADDR Q
- DEBNAM S PRCADBPT=$P(^PRCA(430,PRCABN,0),U,9) Q:PRCADBPT="" I '$D(^RCD(340,PRCADBPT,0)) S PRCADBPT="" Q
- S A1=$P(^RCD(340,PRCADBPT,0),";",1),A2=$P($P(^(0),U,1),";",2),PRCA3=U_A2_A1_",0)",PRCA("DEBTNM")=$S($D(@PRCA3):$P(^(0),U,1),1:"")
- K A1,A2,PRCA3 Q
- DEBADDR S PRCADB=$P(^RCD(340,PRCADBPT,0),"^") S X=$$DADD^RCAMADD(PRCADB) S PRCAST1=$P(X,U,1),PRCAST2=$P(X,U,2),PRCACT=$P(X,U,4),PRCAKP=$P(X,U,6)
- S PRCAST=$P(X,U,5)
- S PRCA("DEBTOR")=1 K PRCADB,PRCADBPT,Z Q ;end of DEBTOR
- ;
- PATTR ;This transfers the pat# field in the file 430 to FILE 433
- ;Input variable : PRCABN,PRCAEN
- Q:('$D(PRCABN))!('$D(PRCAEN)) K ^PRCA(433,PRCAEN,4) S A1="" F I=0:0 S A1=$O(^PRCA(430,PRCABN,2,A1)) Q:A1="" D PATR1
- S ^PRCA(433,PRCAEN,4,0)="^433.01I^"_$P($G(^PRCA(430,PRCABN,2,0)),U,3,4) K A1,A2,X
- S $P(^PRCA(433,PRCAEN,0),U,8)=$P(^PRCA(430,PRCABN,0),U,18) Q ;end of PATTRAN
- PATR1 I $D(^PRCA(430,PRCABN,2,A1,0)) S X=$P(^(0),U,1,3),$P(X,U,4)=1,^PRCA(433,PRCAEN,4,A1,0)=X Q
- S X=0 F I=0:0 S X=$O(^PRCA(430,PRCABN,2,A1,X)) Q:X="" S A2=$O(^(X,0)) I A2]"" S ^PRCA(433,PRCAEN,4,A1,X,A2)=""
- Q
- ;
- TRANUP ;update the fiscal year amounts (file 430) from trans.file (433).
- Q:('$D(PRCAEN))!('$D(PRCABN))
- S Z1=0 F Z2=0:0 S Z1=$O(^PRCA(433,PRCAEN,4,Z1)) Q:Z1'>0 S $P(^PRCA(430,PRCABN,2,Z1,0),U,2)=$P(^PRCA(433,PRCAEN,4,Z1,0),U,2)
- S $P(^PRCA(433,PRCAEN,0),U,4)=2 K Z2,Z1 Q ;end of Z2ANUP
- UNIT ;move the DESCRIPTION field in the 430 to 433.
- Q:'$D(PRCABN)!('$D(PRCAEN)) Q:'$D(^PRCA(430,PRCABN,101,0)) S PRCAK1=0
- F I=0:0 S PRCAK1=$O(^PRCA(430,PRCABN,101,PRCAK1)) Q:'PRCAK1 S ^PRCA(433,PRCAEN,6,PRCAK1,0)=$P(^PRCA(430,PRCABN,101,PRCAK1,0),U,1,6),^PRCA(433,PRCAEN,6,"B",$P(^(0),U,1),PRCAK1)=""
- S ^PRCA(433,PRCAEN,6,0)="^433.061DA^"_$P(^PRCA(430,PRCABN,101,0),U,3,4)
- K PRCAK1,I Q
- TRUNIT ;transfer the DESCRIPTION field in the 433 to 430.
- Q:'$D(PRCABN)!('$D(PRCAEN)) Q:'$D(^PRCA(433,PRCAEN,6,0)) S PRCAK1=0
- F I=0:0 S PRCAK1=$O(^PRCA(433,PRCAEN,6,PRCAK1)) Q:'PRCAK1 S $P(^PRCA(430,PRCABN,101,PRCAK1,0),U,1,6)=$P(^PRCA(433,PRCAEN,6,PRCAK1,0),U,1,6)
- K PRCAK1 Q
- UPATDD ;delete 433,"ATD" cross-reference of old debtor
- Q:'$D(DA) N PRCABN,PRCAEN,PRCADEB,PRCAATD
- S PRCABN=DA,PRCADEB=$E(X,1,30) Q:PRCADEB=""
- S PRCAEN=0 F S PRCAEN=$O(^PRCA(433,"C",PRCABN,PRCAEN)) Q:PRCAEN="" S PRCAATD=$G(^PRCA(433,PRCAEN,1)) I $P(PRCAATD,"^",9),$D(^PRCA(433,"ATD",PRCADEB,$P(PRCAATD,"^",9),PRCAEN)) K ^PRCA(433,"ATD",PRCADEB,$P(PRCAATD,"^",9),PRCAEN)
- Q
- UPATDS ;set 433,"ATD" cross-reference of new debtor
- Q:'$D(DA) N PRCABN,PRCAEN,PRCADEB,PRCAATD
- S PRCABN=DA,PRCADEB=$E(X,1,30) Q:PRCADEB=""
- I $G(^RCD(340,+PRCADEB,0))'["DPT" Q
- S PRCAEN=0 F S PRCAEN=$O(^PRCA(433,"C",PRCABN,PRCAEN)) Q:PRCAEN="" S PRCAATD=$G(^PRCA(433,PRCAEN,1)) I $P(PRCAATD,"^",9) S ^PRCA(433,"ATD",PRCADEB,$P(PRCAATD,"^",9),PRCAEN)=""
- Q
- ;
- EMERES(DFN) ;This code flags a patient that is a victim of an emergent crisis.
- ;If DT falls within the emergency response begin date and end date of
- ;file 342 AR SITE PARAMETER the billing process that calls this will be
- ;suspended.
- I '$G(DFN) Q ""
- N X,PRCABEG,PRCAEND
- ;this code calls the registration utility to flag a patient that is in
- ;an emergent crisis.
- ;
- S X=$$EMGRES^DGUTL(DFN) I X]"" D
- .S PRCABEG=$P($G(^RC(342,1,30)),"^",1)
- .S PRCAEND=$P($G(^RC(342,1,30)),"^",2)
- .I PRCAEND']"",PRCABEG]"" S PRCAEND=9999999
- .I DT<PRCABEG!(DT>PRCAEND) S X=""
- Q X
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAUTL 4568 printed Jan 18, 2025@02:43:17 Page 2
- PRCAUTL ;SF-ISC/YJK-AR UTILITY ROUTINES ;8/16/95 11:41 AM
- +1 ;;4.5;Accounts Receivable;**20,34,88,198,236**;Mar 20, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- SETTR ;Set a new transaction number. Return PRCAEN,X,DA
- +1 FOR DINUM=$PIECE(^PRCA(433,0),"^",3)+1:1
- IF '$DATA(^PRCA(433,DINUM))
- LOCK +^PRCA(433,DINUM):1
- if $TEST
- QUIT
- +2 SET RCDA=DINUM
- SET DIC="^PRCA(433,"
- SET DIC(0)="L"
- SET DLAYGO=433
- SET X=DINUM
- KILL DD,DO
- DO FILE^DICN
- LOCK -^PRCA(433,RCDA)
- KILL RCDA,DIC,DINUM,DLAYGO,DO
- if Y<0
- GOTO SETTR
- +3 SET (PRCAEN,DA)=+Y
- SET $PIECE(^PRCA(433,PRCAEN,0),U,8)=$SELECT($DATA(PRCA("APPR")):PRCA("APPR"),1:"")
- +4 SET $PIECE(^PRCA(433,PRCAEN,0),U,9)=DUZ
- +5 QUIT
- BILL ;Look up a bill number - return PRCABN
- +1 KILL DIC,DA
- BILLN NEW DPTNOFZY,DPTNOFZK
- SET (DPTNOFZY,DPTNOFZK)=1
- +1 WRITE !
- KILL PRCABN
- SET DIC="^PRCA(430,"
- SET DIC(0)="AEQMZ"
- DO ^DIC
- if Y<0
- GOTO EXIT
- SET PRCABN=+Y
- SET PRCATY=$PIECE(^PRCA(430,PRCABN,0),U,2)
- SET PRCA("SEG")=$SELECT(+$PIECE(^(0),U,21)>240:$PIECE(^(0),U,21),1:"")
- +2 SET PRCA("STATUS")=$PIECE(^PRCA(430,PRCABN,0),U,8)
- SET PRCA("APPR")=$PIECE(^(0),U,18)
- EXIT KILL DIC
- QUIT
- +1 ;
- DEBTOR ;Check a debtor name,active address and other debtor's info.
- +1 ;Return the name and address - PRCA("DEBTNM"),PRCAST1,PRCAST2,PRCACT,PRCAST,PRCAKP.
- +2 DO DEBNAM
- if PRCADBPT=""
- QUIT
- DO DEBADDR
- QUIT
- DEBNAM SET PRCADBPT=$PIECE(^PRCA(430,PRCABN,0),U,9)
- if PRCADBPT=""
- QUIT
- IF '$DATA(^RCD(340,PRCADBPT,0))
- SET PRCADBPT=""
- QUIT
- +1 SET A1=$PIECE(^RCD(340,PRCADBPT,0),";",1)
- SET A2=$PIECE($PIECE(^(0),U,1),";",2)
- SET PRCA3=U_A2_A1_",0)"
- SET PRCA("DEBTNM")=$SELECT($DATA(@PRCA3):$PIECE(^(0),U,1),1:"")
- +2 KILL A1,A2,PRCA3
- QUIT
- DEBADDR SET PRCADB=$PIECE(^RCD(340,PRCADBPT,0),"^")
- SET X=$$DADD^RCAMADD(PRCADB)
- SET PRCAST1=$PIECE(X,U,1)
- SET PRCAST2=$PIECE(X,U,2)
- SET PRCACT=$PIECE(X,U,4)
- SET PRCAKP=$PIECE(X,U,6)
- +1 SET PRCAST=$PIECE(X,U,5)
- +2 ;end of DEBTOR
- SET PRCA("DEBTOR")=1
- KILL PRCADB,PRCADBPT,Z
- QUIT
- +3 ;
- PATTR ;This transfers the pat# field in the file 430 to FILE 433
- +1 ;Input variable : PRCABN,PRCAEN
- +2 if ('$DATA(PRCABN))!('$DATA(PRCAEN))
- QUIT
- KILL ^PRCA(433,PRCAEN,4)
- SET A1=""
- FOR I=0:0
- SET A1=$ORDER(^PRCA(430,PRCABN,2,A1))
- if A1=""
- QUIT
- DO PATR1
- +3 SET ^PRCA(433,PRCAEN,4,0)="^433.01I^"_$PIECE($GET(^PRCA(430,PRCABN,2,0)),U,3,4)
- KILL A1,A2,X
- +4 ;end of PATTRAN
- SET $PIECE(^PRCA(433,PRCAEN,0),U,8)=$PIECE(^PRCA(430,PRCABN,0),U,18)
- QUIT
- PATR1 IF $DATA(^PRCA(430,PRCABN,2,A1,0))
- SET X=$PIECE(^(0),U,1,3)
- SET $PIECE(X,U,4)=1
- SET ^PRCA(433,PRCAEN,4,A1,0)=X
- QUIT
- +1 SET X=0
- FOR I=0:0
- SET X=$ORDER(^PRCA(430,PRCABN,2,A1,X))
- if X=""
- QUIT
- SET A2=$ORDER(^(X,0))
- IF A2]""
- SET ^PRCA(433,PRCAEN,4,A1,X,A2)=""
- +2 QUIT
- +3 ;
- TRANUP ;update the fiscal year amounts (file 430) from trans.file (433).
- +1 if ('$DATA(PRCAEN))!('$DATA(PRCABN))
- QUIT
- +2 SET Z1=0
- FOR Z2=0:0
- SET Z1=$ORDER(^PRCA(433,PRCAEN,4,Z1))
- if Z1'>0
- QUIT
- SET $PIECE(^PRCA(430,PRCABN,2,Z1,0),U,2)=$PIECE(^PRCA(433,PRCAEN,4,Z1,0),U,2)
- +3 ;end of Z2ANUP
- SET $PIECE(^PRCA(433,PRCAEN,0),U,4)=2
- KILL Z2,Z1
- QUIT
- UNIT ;move the DESCRIPTION field in the 430 to 433.
- +1 if '$DATA(PRCABN)!('$DATA(PRCAEN))
- QUIT
- if '$DATA(^PRCA(430,PRCABN,101,0))
- QUIT
- SET PRCAK1=0
- +2 FOR I=0:0
- SET PRCAK1=$ORDER(^PRCA(430,PRCABN,101,PRCAK1))
- if 'PRCAK1
- QUIT
- SET ^PRCA(433,PRCAEN,6,PRCAK1,0)=$PIECE(^PRCA(430,PRCABN,101,PRCAK1,0),U,1,6)
- SET ^PRCA(433,PRCAEN,6,"B",$PIECE(^(0),U,1),PRCAK1)=""
- +3 SET ^PRCA(433,PRCAEN,6,0)="^433.061DA^"_$PIECE(^PRCA(430,PRCABN,101,0),U,3,4)
- +4 KILL PRCAK1,I
- QUIT
- TRUNIT ;transfer the DESCRIPTION field in the 433 to 430.
- +1 if '$DATA(PRCABN)!('$DATA(PRCAEN))
- QUIT
- if '$DATA(^PRCA(433,PRCAEN,6,0))
- QUIT
- SET PRCAK1=0
- +2 FOR I=0:0
- SET PRCAK1=$ORDER(^PRCA(433,PRCAEN,6,PRCAK1))
- if 'PRCAK1
- QUIT
- SET $PIECE(^PRCA(430,PRCABN,101,PRCAK1,0),U,1,6)=$PIECE(^PRCA(433,PRCAEN,6,PRCAK1,0),U,1,6)
- +3 KILL PRCAK1
- QUIT
- UPATDD ;delete 433,"ATD" cross-reference of old debtor
- +1 if '$DATA(DA)
- QUIT
- NEW PRCABN,PRCAEN,PRCADEB,PRCAATD
- +2 SET PRCABN=DA
- SET PRCADEB=$EXTRACT(X,1,30)
- if PRCADEB=""
- QUIT
- +3 SET PRCAEN=0
- FOR
- SET PRCAEN=$ORDER(^PRCA(433,"C",PRCABN,PRCAEN))
- if PRCAEN=""
- QUIT
- SET PRCAATD=$GET(^PRCA(433,PRCAEN,1))
- IF $PIECE(PRCAATD,"^",9)
- IF $DATA(^PRCA(433,"ATD",PRCADEB,$PIECE(PRCAATD,"^",9),PRCAEN))
- KILL ^PRCA(433,"ATD",PRCADEB,$PIECE(PRCAATD,"^",9),PRCAEN)
- +4 QUIT
- UPATDS ;set 433,"ATD" cross-reference of new debtor
- +1 if '$DATA(DA)
- QUIT
- NEW PRCABN,PRCAEN,PRCADEB,PRCAATD
- +2 SET PRCABN=DA
- SET PRCADEB=$EXTRACT(X,1,30)
- if PRCADEB=""
- QUIT
- +3 IF $GET(^RCD(340,+PRCADEB,0))'["DPT"
- QUIT
- +4 SET PRCAEN=0
- FOR
- SET PRCAEN=$ORDER(^PRCA(433,"C",PRCABN,PRCAEN))
- if PRCAEN=""
- QUIT
- SET PRCAATD=$GET(^PRCA(433,PRCAEN,1))
- IF $PIECE(PRCAATD,"^",9)
- SET ^PRCA(433,"ATD",PRCADEB,$PIECE(PRCAATD,"^",9),PRCAEN)=""
- +5 QUIT
- +6 ;
- EMERES(DFN) ;This code flags a patient that is a victim of an emergent crisis.
- +1 ;If DT falls within the emergency response begin date and end date of
- +2 ;file 342 AR SITE PARAMETER the billing process that calls this will be
- +3 ;suspended.
- +4 IF '$GET(DFN)
- QUIT ""
- +5 NEW X,PRCABEG,PRCAEND
- +6 ;this code calls the registration utility to flag a patient that is in
- +7 ;an emergent crisis.
- +8 ;
- +9 SET X=$$EMGRES^DGUTL(DFN)
- IF X]""
- Begin DoDot:1
- +10 SET PRCABEG=$PIECE($GET(^RC(342,1,30)),"^",1)
- +11 SET PRCAEND=$PIECE($GET(^RC(342,1,30)),"^",2)
- +12 IF PRCAEND']""
- IF PRCABEG]""
- SET PRCAEND=9999999
- +13 IF DT<PRCABEG!(DT>PRCAEND)
- SET X=""
- End DoDot:1
- +14 QUIT X