source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAKBT1.m@ 1154

Last change on this file since 1154 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.6 KB
Line 
1PRCAKBT1 ;WASH-ISC@ALTOONA,PA/CMS-AR BUILD TEMP ARCHIVE FILE CONT. ;7/3/96 11:17 AM
2V ;;4.5;Accounts Receivable;**46**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 NEW DA,DIC,DIQ,DR,FIL,II,PRCABN
5 F PRCABN=0:0 S PRCABN=$O(^PRCA(430,"AC",STAT,PRCABN)) Q:'PRCABN D SET
6 Q
7SET ;create data records
8 N BN0,DA,PRCATN,TN
9 S BN0=$G(^PRCA(430,PRCABN,0)) I BN0="" K ^PRCA(430,"AC",STAT,PRCABN) Q
10 I $P(BN0,"^")="" S ^TMP("PRCAK",$J,"E",^TMP("PRCAK",$J,"E"))="Bill number not defined for entry #"_PRCABN_" in file 430!",^TMP("PRCAK",$J,"E")=^TMP("PRCAK",$J,"E")+1 Q
11 I '$D(^PRCA(430,"B",$P(BN0,U,1),PRCABN)) S ^PRCA(430,"B",$P(BN0,U,1),PRCABN)=""
12 D P430 I '$D(^UTILITY("DIQ1",$J)) S ^TMP("PRCAK",$J,"E",^TMP("PRCAK",$J,"E"))="Could not set Archive data record for Bill NO. "_$P(BN0,U),^TMP("PRCAK",$J,"E")=^TMP("PRCAK",$J,"E")+1 Q
13 F PRCATN=0:0 S PRCATN=$O(^PRCA(433,"C",PRCABN,PRCATN)) Q:'PRCATN I $G(^PRCA(433,PRCATN,0))'="" D P433
14 K ^UTILITY("DIQ1",$J)
15 Q
16P430 ;get all 430 data
17 N DA,DIC,DIQ,DR,II,SF,SN,TN
18 K ^UTILITY("DIQ1",$J)
19 F II=2,5,10,101 I $D(^PRCA(430,PRCABN,II,0)) D
20 .F SN=0:0 S SN=$O(^PRCA(430,PRCABN,II,SN)) Q:'SN S SF(II,SN)=""
21 S DA=PRCABN,DIC="^PRCA(430,",DIQ(0)="EN",DR=".001:99999999" D EN^DIQ1
22 S DR(430.01)=DR,DR(430.02)=DR,DR(430.051)=DR,DR(430.098)=DR
23 F II=0:0 S II=$O(SF(II)) Q:'II F SN=0:0 S SN=$O(SF(II,SN)) Q:'SN S DA($S(II=2:430.01,II=5:430.051,II=10:430.098,1:430.02))=SN S DIQ(0)="EN" D EN^DIQ1
24 I $D(^UTILITY("DIQ1",$J)) S TN=0 D ENT
25 Q
26P433 ;Get all 433 data
27 N DA,DIC,DIQ,DR,II,SF,SN
28 K ^UTILITY("DIQ1",$J)
29 F II=4,6,7 I $D(^PRCA(433,PRCATN,II,0)) D
30 .F SN=0:0 S SN=$O(^PRCA(433,PRCATN,II,SN)) Q:'SN S SF(II,SN)=""
31 S DA=PRCATN,DIC="^PRCA(433,",DIQ(0)="EN",DR=".001:99999999" D EN^DIQ1
32 S DR(433.01)=DR,DR(433.04)=DR,DR(433.061)=DR
33 F II=0:0 S II=$O(SF(II)) Q:'II F SN=0:0 S SN=$O(SF(II,SN)) Q:'SN S DA($S(II=4:433.01,II=6:433.061,1:433.04))=SN S DIQ(0)="EN" D EN^DIQ1
34 I '$D(^UTILITY("DIQ1",$J)) S ^TMP("PRCAK",$J,"E",^TMP("PRCAK",$J,"E"))="Could not create Archive data record for Tran. No. "_PRCABN_" of Bill # "_$P(BN0,"^"),^TMP("PRCAK",$J,"E")=^TMP("PRCAK",$J,"E")+1 Q
35 S TN=$G(TN)+1 D ENT
36 Q
37ENT ;Enter Data records in File 430.8
38 N DAT,DD,DIC,DINUM,DLAYGO,DO,FIL,FLD,I,IFN,X,Y,LN
39 S DLAYGO=430.8,DIC="^PRCAK(430.8,",DIC(0)="L"
40 S DIC("W")="",X=$P(BN0,"^",1)_"-"_TN D ^DIC
41 I Y<0 S ^TMP("PRCAK",$J,"E",^TMP("PRCAK",$J,"E"))="Could not archive entry "_X_" (IEN: "_PRCABN_") due to invalid identifier.",^TMP("PRCAK",$J,"E")=^TMP("PRCAK",$J,"E")+1 Q
42 I '$P(Y,"^",3) S ^TMP("PRCAK",$J,"E",^TMP("PRCAK",$J,"E"))="Could not archive entry "_X_" (IEN: "_PRCABN_") due to duplicate entry.",^TMP("PRCAK",$J,"E")=^TMP("PRCAK",$J,"E")+1 Q
43 S CNT=$G(CNT)+1,$P(^PRCAK(430.8,+Y,0),"^",2)=$$NAM^RCFN01($P(BN0,"^",9))
44 S $P(^PRCAK(430.8,+Y,0),"^",3)=$$SSN^RCFN01($P(BN0,"^",9)),$P(^(0),"^",4)=0
45 S ^PRCAK(430.8,+Y,1,0)="^^0^0^"_DT_"^"
46 S FIL="" F S FIL=$O(^UTILITY("DIQ1",$J,FIL)) Q:FIL="" F IFN=0:0 S IFN=$O(^UTILITY("DIQ1",$J,FIL,IFN)) Q:'IFN D
47 .S FLD="" F S FLD=$O(^UTILITY("DIQ1",$J,FIL,IFN,FLD)) Q:FLD="" S I=$O(^(FLD,"")) D
48 ..I I="E" S DAT=$G(^TMP("PRCAK",$J,"F",FIL,FLD))_":"_^UTILITY("DIQ1",$J,FIL,IFN,FLD,"E") D ADD I FIL=433,FLD=.01 S $P(^PRCAK(430.8,+Y,0),U,4)=$P(DAT,":",2) Q
49 ..S I=0 F S I=$O(^UTILITY("DIQ1",$J,FIL,IFN,FLD,I)) Q:'I S DAT=$G(^TMP("PRCAK",$J,"F",FIL,FLD))_":"_^UTILITY("DIQ1",$J,FIL,IFN,FLD,I) D ADD
50 .S DAT="" D SAVE
51 Q
52ADD ;add to WP field
53 I $G(LN)="" S LN=" "_DAT Q
54 I ($L(DAT)+$L(LN))<210 S LN=LN_" "_DAT Q
55SAVE S X=$P(^PRCAK(430.8,+Y,1,0),U,4)
56 F Q:LN="" D
57 .S X=X+1
58 .S ^PRCAK(430.8,+Y,1,X,0)=$E(LN,1,245)
59 .S LN=$E(LN,246,9999)
60 .Q
61 S $P(^PRCAK(430.8,+Y,1,0),U,3,4)=X_"^"_X
62 S LN=DAT
63 Q
Note: See TracBrowser for help on using the repository browser.