PRPFPUR1 ;CTB/ALTOONA PURGE ONE PATIENT FUNDS RECORD ;7/15/97 9:55 AM
V ;;3.0;PATIENT FUNDS;**6,7**;JUNE 1, 1989
ONE(X) ;
;PURGE PATIENT FUNDS MASTER TRANSACTION FILE AND PATIENT TRANSACTION
; MULTIPLE FOR ONE PATIENT THRU AND INCLUDING EDATE.
;DFN=INTERNAL REFERENCE FOR PATIENT
;EDATE=INTERNAL FM DATE, ALL TRANSACTIONS THRU AND INCLUDING THIS
; DATE WILL BE SUMMARIZED AND DELETED.
;K ^TMP(UCIJOB,"PRPFPURGE",DFN)
N DATE,ERROR,PBAL,GBAL,TRDA,TRNODE,MADA,MANODE,BAL,REC,MREC,MRECID,UCIJOB,DFN,EDATE
S DFN=$P(X,",",1),EDATE=$P(X,",",2)
X ^%ZOSF("UCI") S UCIJOB=Y_","_$J
S (DATE,ERROR,PBAL,GBAL,BAL)=0
F S DATE=$O(^PRPF(470,DFN,3,"AC",DATE)) Q:DATE=""!(DATE>EDATE)!(ERROR) D
. S (TRDA,ERROR)=0
. F S TRDA=$O(^PRPF(470,DFN,3,"AC",DATE,TRDA)) Q:TRDA="" D Q:ERROR
. . S ERROR=$$VERIFY(DFN,TRDA,DATE) Q:ERROR
. . S ^TMP(UCIJOB,"PRPFPURGE",DFN,TRDA)=""
. . QUIT
. QUIT
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
S TRDA=0,REC=0
F S TRDA=$O(^TMP(UCIJOB,"PRPFPURGE",DFN,TRDA)) Q:'TRDA D
. N TRNODE,TPAMT,TGAMT,TAMT,MADA,MID
. S TRNODE=^PRPF(470,DFN,3,TRDA,0)
. S TPAMT=$P(TRNODE,"^",4),TGAMT=$P(TRNODE,"^",5),TAMT=$P(TRNODE,"^",3),MADA=$P(TRNODE,"^",1),MID=$P(^PRPF(470.1,MADA,0),"^")
. S PBAL=PBAL+TPAMT,GBAL=GBAL+TGAMT,BAL=BAL+TAMT
. S REC=TRDA,MREC=MADA,MRECID=MID
. D ;DELETE MASTER TRANSACTION
. . N NODE
. . S NODE=$G(^PRPF(470.1,MADA,0)) Q:NODE=""
. . I $P(NODE,"^",1)]"" K ^PRPF(470.1,"B",$P(NODE,"^",1),MADA)
. . I $P(NODE,"^",5)]"" K ^PRPF(470.1,"AD",$P(NODE,"^",4),MADA)
. . I $P(NODE,"^",6)]"" K ^PRPF(470.1,"AC",$P(NODE,"^",6),MADA)
. . L +^PRPF(470.1,0):10 I $T S $P(^(0),"^",4)=$P(^PRPF(470.1,0),"^",4)-1 L -^PRPF(470.1,0)
. . K ^PRPF(470.1,MADA)
. . QUIT ;DELETE MASTER TRANSACTION
. D ;DELETE PATIENT TRANSACTION
. . N NODE
. . S NODE=$G(^PRPF(470,DFN,3,TRDA,0)) Q:NODE=""
. . I $P(NODE,"^",1)]"" K ^PRPF(470,DFN,3,"B",$P(NODE,"^",1),TRDA)
. . I $P(NODE,"^",2)]"" K ^PRPF(470,DFN,3,"AC",$P(NODE,"^",2),TRDA)
. . 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)
. . K ^PRPF(470,DFN,3,TRDA)
. . QUIT ;DELETE PATIENT TRANSACTION
. QUIT
;ENTER BALANCE CARRIED FORWARD TRANSACTION
Q:REC=0
L +^PRPF
S $P(^PRPF(470.1,0),"^",4)=$P(^PRPF(470.1,0),"^",4)+1
S $P(^PRPF(470,DFN,3,0),"^",4)=$P(^PRPF(470,DFN,3,0),"^",4)+1
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)=""
S X=$O(^PRPF(470.2,"B","BALCARFWD",0))
S MREC(0)=MRECID_"^"_DFN_"^"_REC_"^"_BAL_"^"_EDATE_"^"_EDATE_"^BALCARFWD^D^3^B^"_X_"^"_PBAL_"^"_GBAL_"^"_DUZ_"^^Balance Carried Forward - Purge"
S MREC(1)=$P(^VA(200,DUZ,0),"^")
S STRING=$$SUM^PRPFSIG(MREC_"^"_$P(MREC(0),"^",4,6))
S $P(MREC(0),"^",15)=$$ENCODE^PRPFSIG(MREC(1),DUZ,STRING)
S ^PRPF(470.1,MREC,0)=MREC(0),^(1)=MREC(1)
S ^PRPF(470.1,"B",MRECID,MREC)="",^PRPF(470.1,"AD",EDATE,MREC)="",^PRPF(470.1,"AC",EDATE,MREC)=""
L -^PRPF
K ^TMP(UCIJOB,"PRPFPURGE")
QUIT
;
VERIFY(DFN,TRDA,DATE) ;VERIFY INTEGRITY OF INDIVIDUAL PATIENT TRANSACTION
; AND ASSOCIATED MASTER TRANSACTION.
N TRNODE,ERROR,TDATE,MDATE,MAMT,MPAMT,MGAMT,TGAMT,TAMT,TPAMT,TBAL,MADA,MNODE
S TRNODE=$G(^PRPF(470,DFN,3,TRDA,0)) I TRNODE="" S ERROR=1 D ERROR Q
S TDATE=$P(TRNODE,"^",2),TAMT=$P(TRNODE,"^",3),TPAMT=$P(TRNODE,"^",4),TGAMT=$P(TRNODE,"^",5),TBAL=$P(TRNODE,"^",6),MADA=+TRNODE
S MNODE=$G(^PRPF(470.1,+MADA,0)) I MNODE="" S ERROR=3 D ERROR Q 1
S MDATE=$P(MNODE,"^",5),MAMT=$P(MNODE,"^",4),MPAMT=$P(MNODE,"^",12),MGAMT=$P(MNODE,"^",13)
I TDATE=""!(TDATE'=$P(DATE,".")) S ERROR=1 D ERROR Q 1
I (+TAMT'=+MAMT)!(+TPAMT'=+MPAMT)!(+TGAMT'=+MGAMT) S ERROR=4 D ERROR Q 1
I MDATE'=TDATE S ERROR=2 D ERROR Q 1
Q 0
ERROR S X=$P($T(ERROR+ERROR),";",3,99)_" "_TRDA D MSG^PRPFU1 W ! Q
;;INVALID 'AC' CROSS REFERENCE IN FILE 470, FIELD 30
;;DATE IN TRANSACTION MULTIPLE OF 470 DOES NOT MATCH CROSS REFERENCE
;;PATIENT TRANSACTION MULTIPLE POINTS TO INVALID MASTER RECORD
;;BALANCES ARE OUT OF DATE BETWEEN MASTER TRANSACTION FILE AND PATIENT TRANSACTION MULTIPLE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFPUR1 4236 printed Dec 13, 2024@02:01:55 Page 2
PRPFPUR1 ;CTB/ALTOONA PURGE ONE PATIENT FUNDS RECORD ;7/15/97 9:55 AM
V ;;3.0;PATIENT FUNDS;**6,7**;JUNE 1, 1989
ONE(X) ;
+1 ;PURGE PATIENT FUNDS MASTER TRANSACTION FILE AND PATIENT TRANSACTION
+2 ; MULTIPLE FOR ONE PATIENT THRU AND INCLUDING EDATE.
+3 ;DFN=INTERNAL REFERENCE FOR PATIENT
+4 ;EDATE=INTERNAL FM DATE, ALL TRANSACTIONS THRU AND INCLUDING THIS
+5 ; DATE WILL BE SUMMARIZED AND DELETED.
+6 ;K ^TMP(UCIJOB,"PRPFPURGE",DFN)
+7 NEW DATE,ERROR,PBAL,GBAL,TRDA,TRNODE,MADA,MANODE,BAL,REC,MREC,MRECID,UCIJOB,DFN,EDATE
+8 SET DFN=$PIECE(X,",",1)
SET EDATE=$PIECE(X,",",2)
+9 XECUTE ^%ZOSF("UCI")
SET UCIJOB=Y_","_$JOB
+10 SET (DATE,ERROR,PBAL,GBAL,BAL)=0
+11 FOR
SET DATE=$ORDER(^PRPF(470,DFN,3,"AC",DATE))
if DATE=""!(DATE>EDATE)!(ERROR)
QUIT
Begin DoDot:1
+12 SET (TRDA,ERROR)=0
+13 FOR
SET TRDA=$ORDER(^PRPF(470,DFN,3,"AC",DATE,TRDA))
if TRDA=""
QUIT
Begin DoDot:2
+14 SET ERROR=$$VERIFY(DFN,TRDA,DATE)
if ERROR
QUIT
+15 SET ^TMP(UCIJOB,"PRPFPURGE",DFN,TRDA)=""
+16 QUIT
End DoDot:2
if ERROR
QUIT
+17 QUIT
End DoDot:1
+18 IF ERROR
SET X="ERROR FOUND IN PROCESSING PURGE FOR "_$PIECE(^DPT(DFN,0),"^",1)_". <No Purge has occurred for this patient>"
DO MSG^PRPFU1
QUIT
+19 SET TRDA=0
SET REC=0
+20 FOR
SET TRDA=$ORDER(^TMP(UCIJOB,"PRPFPURGE",DFN,TRDA))
if 'TRDA
QUIT
Begin DoDot:1
+21 NEW TRNODE,TPAMT,TGAMT,TAMT,MADA,MID
+22 SET TRNODE=^PRPF(470,DFN,3,TRDA,0)
+23 SET TPAMT=$PIECE(TRNODE,"^",4)
SET TGAMT=$PIECE(TRNODE,"^",5)
SET TAMT=$PIECE(TRNODE,"^",3)
SET MADA=$PIECE(TRNODE,"^",1)
SET MID=$PIECE(^PRPF(470.1,MADA,0),"^")
+24 SET PBAL=PBAL+TPAMT
SET GBAL=GBAL+TGAMT
SET BAL=BAL+TAMT
+25 SET REC=TRDA
SET MREC=MADA
SET MRECID=MID
+26 ;DELETE MASTER TRANSACTION
Begin DoDot:2
+27 NEW NODE
+28 SET NODE=$GET(^PRPF(470.1,MADA,0))
if NODE=""
QUIT
+29 IF $PIECE(NODE,"^",1)]""
KILL ^PRPF(470.1,"B",$PIECE(NODE,"^",1),MADA)
+30 IF $PIECE(NODE,"^",5)]""
KILL ^PRPF(470.1,"AD",$PIECE(NODE,"^",4),MADA)
+31 IF $PIECE(NODE,"^",6)]""
KILL ^PRPF(470.1,"AC",$PIECE(NODE,"^",6),MADA)
+32 LOCK +^PRPF(470.1,0):10
IF $TEST
SET $PIECE(^(0),"^",4)=$PIECE(^PRPF(470.1,0),"^",4)-1
LOCK -^PRPF(470.1,0)
+33 KILL ^PRPF(470.1,MADA)
+34 ;DELETE MASTER TRANSACTION
QUIT
End DoDot:2
+35 ;DELETE PATIENT TRANSACTION
Begin DoDot:2
+36 NEW NODE
+37 SET NODE=$GET(^PRPF(470,DFN,3,TRDA,0))
if NODE=""
QUIT
+38 IF $PIECE(NODE,"^",1)]""
KILL ^PRPF(470,DFN,3,"B",$PIECE(NODE,"^",1),TRDA)
+39 IF $PIECE(NODE,"^",2)]""
KILL ^PRPF(470,DFN,3,"AC",$PIECE(NODE,"^",2),TRDA)
+40 LOCK +^PRPF(470,DFN,3,0):10
IF $TEST
SET $PIECE(^(0),"^",4)=$PIECE(^PRPF(470,DFN,3,0),"^",4)-1
LOCK -^PRPF(470,DFN,3,0)
+41 KILL ^PRPF(470,DFN,3,TRDA)
+42 ;DELETE PATIENT TRANSACTION
QUIT
End DoDot:2
+43 QUIT
End DoDot:1
+44 ;ENTER BALANCE CARRIED FORWARD TRANSACTION
+45 if REC=0
QUIT
+46 LOCK +^PRPF
+47 SET $PIECE(^PRPF(470.1,0),"^",4)=$PIECE(^PRPF(470.1,0),"^",4)+1
+48 SET $PIECE(^PRPF(470,DFN,3,0),"^",4)=$PIECE(^PRPF(470,DFN,3,0),"^",4)+1
+49 SET ^PRPF(470,DFN,3,REC,0)=MREC_"^"_EDATE_"^"_BAL_"^"_PBAL_"^"_GBAL_"^"
SET ^PRPF(470,DFN,3,"B",MREC,REC)=""
SET ^PRPF(470,DFN,3,"AC",EDATE,REC)=""
+50 SET X=$ORDER(^PRPF(470.2,"B","BALCARFWD",0))
+51 SET MREC(0)=MRECID_"^"_DFN_"^"_REC_"^"_BAL_"^"_EDATE_"^"_EDATE_"^BALCARFWD^D^3^B^"_X_"^"_PBAL_"^"_GBAL_"^"_DUZ_"^^Balance Carried Forward - Purge"
+52 SET MREC(1)=$PIECE(^VA(200,DUZ,0),"^")
+53 SET STRING=$$SUM^PRPFSIG(MREC_"^"_$PIECE(MREC(0),"^",4,6))
+54 SET $PIECE(MREC(0),"^",15)=$$ENCODE^PRPFSIG(MREC(1),DUZ,STRING)
+55 SET ^PRPF(470.1,MREC,0)=MREC(0)
SET ^(1)=MREC(1)
+56 SET ^PRPF(470.1,"B",MRECID,MREC)=""
SET ^PRPF(470.1,"AD",EDATE,MREC)=""
SET ^PRPF(470.1,"AC",EDATE,MREC)=""
+57 LOCK -^PRPF
+58 KILL ^TMP(UCIJOB,"PRPFPURGE")
+59 QUIT
+60 ;
VERIFY(DFN,TRDA,DATE) ;VERIFY INTEGRITY OF INDIVIDUAL PATIENT TRANSACTION
+1 ; AND ASSOCIATED MASTER TRANSACTION.
+2 NEW TRNODE,ERROR,TDATE,MDATE,MAMT,MPAMT,MGAMT,TGAMT,TAMT,TPAMT,TBAL,MADA,MNODE
+3 SET TRNODE=$GET(^PRPF(470,DFN,3,TRDA,0))
IF TRNODE=""
SET ERROR=1
DO ERROR
QUIT
+4 SET TDATE=$PIECE(TRNODE,"^",2)
SET TAMT=$PIECE(TRNODE,"^",3)
SET TPAMT=$PIECE(TRNODE,"^",4)
SET TGAMT=$PIECE(TRNODE,"^",5)
SET TBAL=$PIECE(TRNODE,"^",6)
SET MADA=+TRNODE
+5 SET MNODE=$GET(^PRPF(470.1,+MADA,0))
IF MNODE=""
SET ERROR=3
DO ERROR
QUIT 1
+6 SET MDATE=$PIECE(MNODE,"^",5)
SET MAMT=$PIECE(MNODE,"^",4)
SET MPAMT=$PIECE(MNODE,"^",12)
SET MGAMT=$PIECE(MNODE,"^",13)
+7 IF TDATE=""!(TDATE'=$PIECE(DATE,"."))
SET ERROR=1
DO ERROR
QUIT 1
+8 IF (+TAMT'=+MAMT)!(+TPAMT'=+MPAMT)!(+TGAMT'=+MGAMT)
SET ERROR=4
DO ERROR
QUIT 1
+9 IF MDATE'=TDATE
SET ERROR=2
DO ERROR
QUIT 1
+10 QUIT 0
ERROR SET X=$PIECE($TEXT(ERROR+ERROR),";",3,99)_" "_TRDA
DO MSG^PRPFU1
WRITE !
QUIT
+1 ;;INVALID 'AC' CROSS REFERENCE IN FILE 470, FIELD 30
+2 ;;DATE IN TRANSACTION MULTIPLE OF 470 DOES NOT MATCH CROSS REFERENCE
+3 ;;PATIENT TRANSACTION MULTIPLE POINTS TO INVALID MASTER RECORD
+4 ;;BALANCES ARE OUT OF DATE BETWEEN MASTER TRANSACTION FILE AND PATIENT TRANSACTION MULTIPLE
