source: FOIAVistA/tag/r/INTEGRATED_PATIENT_FUNDS-PRPF-PFXIP/PRPFPUR1.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.1 KB
Line 
1PRPFPUR1 ;CTB/ALTOONA PURGE ONE PATIENT FUNDS RECORD ;7/15/97 9:55 AM
2V ;;3.0;PATIENT FUNDS;**6,7**;JUNE 1, 1989
3ONE(X) ;
4 ;PURGE PATIENT FUNDS MASTER TRANSACTION FILE AND PATIENT TRANSACTION
5 ; MULTIPLE FOR ONE PATIENT THRU AND INCLUDING EDATE.
6 ;DFN=INTERNAL REFERENCE FOR PATIENT
7 ;EDATE=INTERNAL FM DATE, ALL TRANSACTIONS THRU AND INCLUDING THIS
8 ; DATE WILL BE SUMMARIZED AND DELETED.
9 ;K ^TMP(UCIJOB,"PRPFPURGE",DFN)
10 N DATE,ERROR,PBAL,GBAL,TRDA,TRNODE,MADA,MANODE,BAL,REC,MREC,MRECID,UCIJOB,DFN,EDATE
11 S DFN=$P(X,",",1),EDATE=$P(X,",",2)
12 X ^%ZOSF("UCI") S UCIJOB=Y_","_$J
13 S (DATE,ERROR,PBAL,GBAL,BAL)=0
14 F S DATE=$O(^PRPF(470,DFN,3,"AC",DATE)) Q:DATE=""!(DATE>EDATE)!(ERROR) D
15 . S (TRDA,ERROR)=0
16 . F S TRDA=$O(^PRPF(470,DFN,3,"AC",DATE,TRDA)) Q:TRDA="" D Q:ERROR
17 . . S ERROR=$$VERIFY(DFN,TRDA,DATE) Q:ERROR
18 . . S ^TMP(UCIJOB,"PRPFPURGE",DFN,TRDA)=""
19 . . QUIT
20 . QUIT
21 I ERROR S X="ERROR FOUND IN PROCESSING PURGE FOR "_$P(^DPT(DFN,0),"^",1)_". <No Purge has occurred for this patient>" D MSG^PRPFU1 Q
22 S TRDA=0,REC=0
23 F S TRDA=$O(^TMP(UCIJOB,"PRPFPURGE",DFN,TRDA)) Q:'TRDA D
24 . N TRNODE,TPAMT,TGAMT,TAMT,MADA,MID
25 . S TRNODE=^PRPF(470,DFN,3,TRDA,0)
26 . S TPAMT=$P(TRNODE,"^",4),TGAMT=$P(TRNODE,"^",5),TAMT=$P(TRNODE,"^",3),MADA=$P(TRNODE,"^",1),MID=$P(^PRPF(470.1,MADA,0),"^")
27 . S PBAL=PBAL+TPAMT,GBAL=GBAL+TGAMT,BAL=BAL+TAMT
28 . S REC=TRDA,MREC=MADA,MRECID=MID
29 . D ;DELETE MASTER TRANSACTION
30 . . N NODE
31 . . S NODE=$G(^PRPF(470.1,MADA,0)) Q:NODE=""
32 . . I $P(NODE,"^",1)]"" K ^PRPF(470.1,"B",$P(NODE,"^",1),MADA)
33 . . I $P(NODE,"^",5)]"" K ^PRPF(470.1,"AD",$P(NODE,"^",4),MADA)
34 . . I $P(NODE,"^",6)]"" K ^PRPF(470.1,"AC",$P(NODE,"^",6),MADA)
35 . . L +^PRPF(470.1,0):10 I $T S $P(^(0),"^",4)=$P(^PRPF(470.1,0),"^",4)-1 L -^PRPF(470.1,0)
36 . . K ^PRPF(470.1,MADA)
37 . . QUIT ;DELETE MASTER TRANSACTION
38 . D ;DELETE PATIENT TRANSACTION
39 . . N NODE
40 . . S NODE=$G(^PRPF(470,DFN,3,TRDA,0)) Q:NODE=""
41 . . I $P(NODE,"^",1)]"" K ^PRPF(470,DFN,3,"B",$P(NODE,"^",1),TRDA)
42 . . I $P(NODE,"^",2)]"" K ^PRPF(470,DFN,3,"AC",$P(NODE,"^",2),TRDA)
43 . . L +^PRPF(470,DFN,3,0):10 I $T S $P(^(0),"^",4)=$P(^PRPF(470,DFN,3,0),"^",4)-1 L -^PRPF(470,DFN,3,0)
44 . . K ^PRPF(470,DFN,3,TRDA)
45 . . QUIT ;DELETE PATIENT TRANSACTION
46 . QUIT
47 ;ENTER BALANCE CARRIED FORWARD TRANSACTION
48 Q:REC=0
49 L +^PRPF
50 S $P(^PRPF(470.1,0),"^",4)=$P(^PRPF(470.1,0),"^",4)+1
51 S $P(^PRPF(470,DFN,3,0),"^",4)=$P(^PRPF(470,DFN,3,0),"^",4)+1
52 S ^PRPF(470,DFN,3,REC,0)=MREC_"^"_EDATE_"^"_BAL_"^"_PBAL_"^"_GBAL_"^",^PRPF(470,DFN,3,"B",MREC,REC)="",^PRPF(470,DFN,3,"AC",EDATE,REC)=""
53 S X=$O(^PRPF(470.2,"B","BALCARFWD",0))
54 S MREC(0)=MRECID_"^"_DFN_"^"_REC_"^"_BAL_"^"_EDATE_"^"_EDATE_"^BALCARFWD^D^3^B^"_X_"^"_PBAL_"^"_GBAL_"^"_DUZ_"^^Balance Carried Forward - Purge"
55 S MREC(1)=$P(^VA(200,DUZ,0),"^")
56 S STRING=$$SUM^PRPFSIG(MREC_"^"_$P(MREC(0),"^",4,6))
57 S $P(MREC(0),"^",15)=$$ENCODE^PRPFSIG(MREC(1),DUZ,STRING)
58 S ^PRPF(470.1,MREC,0)=MREC(0),^(1)=MREC(1)
59 S ^PRPF(470.1,"B",MRECID,MREC)="",^PRPF(470.1,"AD",EDATE,MREC)="",^PRPF(470.1,"AC",EDATE,MREC)=""
60 L -^PRPF
61 K ^TMP(UCIJOB,"PRPFPURGE")
62 QUIT
63 ;
64VERIFY(DFN,TRDA,DATE) ;VERIFY INTEGRITY OF INDIVIDUAL PATIENT TRANSACTION
65 ; AND ASSOCIATED MASTER TRANSACTION.
66 N TRNODE,ERROR,TDATE,MDATE,MAMT,MPAMT,MGAMT,TGAMT,TAMT,TPAMT,TBAL,MADA,MNODE
67 S TRNODE=$G(^PRPF(470,DFN,3,TRDA,0)) I TRNODE="" S ERROR=1 D ERROR Q
68 S TDATE=$P(TRNODE,"^",2),TAMT=$P(TRNODE,"^",3),TPAMT=$P(TRNODE,"^",4),TGAMT=$P(TRNODE,"^",5),TBAL=$P(TRNODE,"^",6),MADA=+TRNODE
69 S MNODE=$G(^PRPF(470.1,+MADA,0)) I MNODE="" S ERROR=3 D ERROR Q 1
70 S MDATE=$P(MNODE,"^",5),MAMT=$P(MNODE,"^",4),MPAMT=$P(MNODE,"^",12),MGAMT=$P(MNODE,"^",13)
71 I TDATE=""!(TDATE'=$P(DATE,".")) S ERROR=1 D ERROR Q 1
72 I (+TAMT'=+MAMT)!(+TPAMT'=+MPAMT)!(+TGAMT'=+MGAMT) S ERROR=4 D ERROR Q 1
73 I MDATE'=TDATE S ERROR=2 D ERROR Q 1
74 Q 0
75ERROR S X=$P($T(ERROR+ERROR),";",3,99)_" "_TRDA D MSG^PRPFU1 W ! Q
76 ;;INVALID 'AC' CROSS REFERENCE IN FILE 470, FIELD 30
77 ;;DATE IN TRANSACTION MULTIPLE OF 470 DOES NOT MATCH CROSS REFERENCE
78 ;;PATIENT TRANSACTION MULTIPLE POINTS TO INVALID MASTER RECORD
79 ;;BALANCES ARE OUT OF DATE BETWEEN MASTER TRANSACTION FILE AND PATIENT TRANSACTION MULTIPLE
Note: See TracBrowser for help on using the repository browser.