| [613] | 1 | PRCAPAT1 ;SF-ISC/YJK-SUBROUTINE - ASSIGN PAT REF# ,ALD CODE AND CALM CODE SHEET ;12/27/93 11:14 AM
|
|---|
| 2 | V ;;4.5;Accounts Receivable;**64**;Mar 20, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;Assign pat ref # and generate CALM code sheet for new accounts rec.
|
|---|
| 5 | ;this is for accounting technician.
|
|---|
| 6 | ;Called by ^PRCAPAT
|
|---|
| 7 | UP442 S DA=PRCHPO,DIE="^PRC(442,",DR=".1///"_DT_";5.1///"_PRCA("DEBTOR")_"" D ^DIE
|
|---|
| 8 | Q
|
|---|
| 9 | DT S %DT="",X="T" D ^%DT S DT=+Y K %DT
|
|---|
| 10 | Q
|
|---|
| 11 | SETAMIS ;set AMIS data for new accounts receivable.
|
|---|
| 12 | S PRCAKCAT=$P(^PRCA(430,PRCABN,0),U,2) I PRCAKCAT'=$O(^PRCA(430.2,"AC",21,0)) Q:$P(^PRCA(430.2,PRCAKCAT,0),U,3)<240
|
|---|
| 13 | D:'$D(DT) DT S:DT["." DT=$P(DT,".",1) S DIE="^PRCA(430,",DA=PRCABN,DR="16////"_DT_"" D ^DIE K DIE,DA,DR,PRCAKCAT S PRCAMIS=1 Q
|
|---|
| 14 | DISPL W:$D(IOF) @IOF K DXS D ^PRCATO8 K DXS Q
|
|---|
| 15 | EDGL ;S DIE="^PRCA(430,",DR="4",DA=PRCABN D ^DIE K DIE,DR,DA Q:$D(Y)
|
|---|
| 16 | I '$D(PRCA("SITE")) S PRCA("SITE")=$S($G(PRCABN):$P($P($G(^PRCA(430,PRCABN,0)),"^"),"-"),1:$$SITE^RCMSITE)
|
|---|
| 17 | D CP^PRCABIL1
|
|---|
| 18 | S DIC="^PRCA(430,"_PRCABN_",2,",DIC(0)="AEQ" D ^DIC Q:+Y'>0 S DA=+Y
|
|---|
| 19 | S DIE=DIC,DA(1)=PRCABN,DR="3" D ^DIE K DIE,DR,DA,DIC Q
|
|---|
