Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCAUTL

PRCAUTL.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. SETTR ;Set a new transaction number. Return PRCAEN,X,DA
  1. F DINUM=$P(^PRCA(433,0),"^",3)+1:1 I '$D(^PRCA(433,DINUM)) L +^PRCA(433,DINUM):1 Q:$T
  1. 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
  1. S (PRCAEN,DA)=+Y,$P(^PRCA(433,PRCAEN,0),U,8)=$S($D(PRCA("APPR")):PRCA("APPR"),1:"")
  1. S $P(^PRCA(433,PRCAEN,0),U,9)=DUZ
  1. Q
  1. BILL ;Look up a bill number - return PRCABN
  1. K DIC,DA
  1. BILLN N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
  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:"")
  1. S PRCA("STATUS")=$P(^PRCA(430,PRCABN,0),U,8),PRCA("APPR")=$P(^(0),U,18)
  1. EXIT K DIC Q
  1. ;
  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.
  1. D DEBNAM Q:PRCADBPT="" D DEBADDR Q
  1. DEBNAM S PRCADBPT=$P(^PRCA(430,PRCABN,0),U,9) Q:PRCADBPT="" I '$D(^RCD(340,PRCADBPT,0)) S PRCADBPT="" Q
  1. 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:"")
  1. K A1,A2,PRCA3 Q
  1. 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)
  1. S PRCAST=$P(X,U,5)
  1. S PRCA("DEBTOR")=1 K PRCADB,PRCADBPT,Z Q ;end of DEBTOR
  1. ;
  1. PATTR ;This transfers the pat# field in the file 430 to FILE 433
  1. ;Input variable : PRCABN,PRCAEN
  1. 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
  1. S ^PRCA(433,PRCAEN,4,0)="^433.01I^"_$P($G(^PRCA(430,PRCABN,2,0)),U,3,4) K A1,A2,X
  1. S $P(^PRCA(433,PRCAEN,0),U,8)=$P(^PRCA(430,PRCABN,0),U,18) Q ;end of PATTRAN
  1. 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
  1. 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)=""
  1. Q
  1. ;
  1. TRANUP ;update the fiscal year amounts (file 430) from trans.file (433).
  1. Q:('$D(PRCAEN))!('$D(PRCABN))
  1. 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)
  1. S $P(^PRCA(433,PRCAEN,0),U,4)=2 K Z2,Z1 Q ;end of Z2ANUP
  1. UNIT ;move the DESCRIPTION field in the 430 to 433.
  1. Q:'$D(PRCABN)!('$D(PRCAEN)) Q:'$D(^PRCA(430,PRCABN,101,0)) S PRCAK1=0
  1. 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)=""
  1. S ^PRCA(433,PRCAEN,6,0)="^433.061DA^"_$P(^PRCA(430,PRCABN,101,0),U,3,4)
  1. K PRCAK1,I Q
  1. TRUNIT ;transfer the DESCRIPTION field in the 433 to 430.
  1. Q:'$D(PRCABN)!('$D(PRCAEN)) Q:'$D(^PRCA(433,PRCAEN,6,0)) S PRCAK1=0
  1. 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)
  1. K PRCAK1 Q
  1. UPATDD ;delete 433,"ATD" cross-reference of old debtor
  1. Q:'$D(DA) N PRCABN,PRCAEN,PRCADEB,PRCAATD
  1. S PRCABN=DA,PRCADEB=$E(X,1,30) Q:PRCADEB=""
  1. 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)
  1. Q
  1. UPATDS ;set 433,"ATD" cross-reference of new debtor
  1. Q:'$D(DA) N PRCABN,PRCAEN,PRCADEB,PRCAATD
  1. S PRCABN=DA,PRCADEB=$E(X,1,30) Q:PRCADEB=""
  1. I $G(^RCD(340,+PRCADEB,0))'["DPT" Q
  1. 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)=""
  1. Q
  1. ;
  1. 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
  1. ;file 342 AR SITE PARAMETER the billing process that calls this will be
  1. ;suspended.
  1. I '$G(DFN) Q ""
  1. N X,PRCABEG,PRCAEND
  1. ;this code calls the registration utility to flag a patient that is in
  1. ;an emergent crisis.
  1. ;
  1. S X=$$EMGRES^DGUTL(DFN) I X]"" D
  1. .S PRCABEG=$P($G(^RC(342,1,30)),"^",1)
  1. .S PRCAEND=$P($G(^RC(342,1,30)),"^",2)
  1. .I PRCAEND']"",PRCABEG]"" S PRCAEND=9999999
  1. .I DT<PRCABEG!(DT>PRCAEND) S X=""
  1. Q X