- 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 Feb 18, 2025@23:28:16 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
