ABSPOSK1 ; IHS/FCS/DRS - winnow POS data ; [ 04/03/2002 10:05 AM ]
;;1.0;PHARMACY POINT OF SALE;**1,48,49**;JUN 21, 2001;Build 38
Q
;
; IHS/SD/lwj 04/03/02 as per David's fix at ANMC - changed
; the check date so that it represents the date and time
; Without this fix, the log files are not being deleted properly.
; One change made to the "D" field in the LOGFILES subroutine.
;
; Contains the routines to evaluate one given entry
; The IEN is given to each one. Called from loops in ABSPOSK
; Also passed in here: AGE(*) array, BILLSYS
03 ;EP - 9002313.03 Responses
N X,CLAIM,RECD S X=^ABSPR(IEN,0),CLAIM=$P(X,U),RECD=$P(X,U,2)
I 'AGE("WINNOW .03 RAW DATA") S AGE("WINNOW .03 RAW DATA")=30
I 'AGE("WINNOW .03 CONTENTS") S AGE("WINNOW .03 CONTENTS")=366
; The raw copy of the packet doesn't have to be kept around very
; long - it's only there for diagnostic purposes; rarely used.
I $$AGE(RECD)>AGE("WINNOW .03 RAW DATA") D
. I $D(^ABSPR(IEN,"M")) D DELFIELD(9002313.03,IEN,9999)
; The contents should stick around awhile longer.
; In addition, if we're using the A/R interface, also require
; that the charge have been posted and that the bill have
; a zero balance.
I ISILCAR,'$$CLOSED02(CLAIM) Q
I $$PT5759(3) Q ; no delete if pointed to by transaction
I $$AGE02(CLAIM)>AGE("WINNOW .03 CONTENTS") D DELETE(9002313.03,IEN)
Q
02 ;EP - 9002313.02 Claims
; Use the transmit date if it's there; otherwise the create date.
I 'AGE("WINNOW .02 RAW DATA") S AGE("WINNOW .02 RAW DATA")=30
I 'AGE("WINNOW .02 CONTENTS") S AGE("WINNOW .02 CONTENTS")=366
; Raw copy of the packet can be short-lived
I $$AGE02(IEN)>AGE("WINNOW .02 RAW DATA") D
. I $D(^ABSPC(IEN,"M")) D DELFIELD(9002313.02,IEN,9999)
; If using ILC A/R interface, also require that the charges have
; been posted and that the bill have a zero balance.
I ISILCAR,'$$CLOSED02(IEN) Q
I $$PT5759(2) Q ; no delete if pointed to by transaction
I $O(^ABSPR("B",IEN,0)) Q ; no delete if pointed to by .03
I $$AGE02(IEN)>AGE("WINNOW .02 CONTENTS") D DELETE(9002313.02,IEN)
Q
PT5759(F) ; does any 9002313.57 or 9002313.59 point to this claim or resp. IEN
; IEN points to the 9002313.02 or 9002313.03, too
; F = 2 for claims, F=3 for responses
N RET,INDEX,FF S RET=0
I F=2 D
. F INDEX="AE","AER" F FF=9002313.57,9002313.59 D
. . I FF=9002313.57,$O(^ABSPTL(INDEX,IEN,0)) S RET=1
. . I FF=9002313.59,$O(^ABSPT(INDEX,IEN,0)) S RET=1
E I F=3 D
. F INDEX="AF","AFR" F FF=9002313.57,9002313.59 D
. . I FF=9002313.57,$O(^ABSPTL(INDEX,IEN,0)) S RET=1
. . I FF=9002313.59,$O(^ABSPT(INDEX,IEN,0)) S RET=1
E D IMPOSS^ABSPOSUE("P","TI","Bad arg F="_F,,"PT5759",$T(+0))
Q RET
AGE02(N) ; how old is the 9002313.02 entry?
; if dates are totally missing, it inserts a date
; Use transmit date if it's there; otherwise created date
N X,Y S X=^ABSPC(N,0)
S Y=$P(X,U,5) I 'Y S Y=$P(X,U,6) I 'Y D Q:Y 0 Q $$IMPOSS^ABSPOSUE("DB","TI","Unable to store dates into ^ABSPC("_N,,"AGE02",$T(+0))
. D LOG("Setting current date into 9002313.02 IEN="_N)
AG5 . N FDA,MSG S FDA(9002313.02,N_",",.06)="NOW"
. D FILE^DIE("E","FDA","MSG")
. I $D(MSG) D LOG^ABSPOSL2("AG5^ABSPOSK1",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
. I $D(MSG) G AG5:$$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"AGE02",$T(+0))
. S Y=$$GET1^DIQ(9002313.02,N_",",.06,"I")
Q $$AGE(Y)
CLOSED02(N) ; is ^ABSPC(N,... posted to A/R and with a zero balance?
; ILC A/R only !!! This code is not reached for other A/R types
; (also returns true if the .02 is unposted for over a year)
N PCN,BBLIMIT S PCN=$P(^ABSPC(N,0),U,3)
I PCN Q '$G(^ABSBITMS(9002302,PCN,3),U) ; true if zero balance
; not posted - is it over a year old?
; Q $$AGE02(N)>365
; /IHS/OIT/RAM ; 16 OCT 2017 ; CR#09828 Changes the amount of time we can back-bill payers; change
; 1 year limit to a new field in the ABSP SETUP file with that parameter. Default is now 6 years.
; S BBLIMIT=+$G(^ABSP(9002313.99,1,"BACKLIMIT")) ; Grab default from ABSP SETUP file.
; I BBLIMIT=0 S BBLIMIT=2192 ; If there is no value, set it to 6 years (in days).
S BBLIMIT=365 ; 31 OCT 17 ; CR 9828 IS NOW ON HOLD; CHANGE BACK TO ORIGINAL 1 YEAR BEHAVIOUR.
Q $$AGE02(N)>BBLIMIT ; Return 1 if within the time limit, 0 otherwise.
; /IHS/OIT/RAM ; 16 OCT 2017 ; END OF CHANGES FOR CR#09828
51 ;EP - 9002313.51 Input
; a month is more than enough
I 'AGE("WINNOW .51") S AGE("WINNOW .51")=31
I $$AGE($P(^ABSP(9002313.51,IEN,0),U))>AGE("WINNOW .51") D
. D DELETE(9002313.51,IEN)
Q
511 ;EP - 9002313.511 Override
I 'AGE("WINNOW .511") S AGE("WINNOW .511")=366
I $$AGE($P(^ABSP(9002313.51,IEN,0),U,2))>AGE("WINNOW .511") D
. D DELETE(9002313.511,IEN)
Q
ALL57 ;EP - temporary - development use
N DA F S DA=$O(^ABSPTL(0)) Q:'DA D
. S DIE=9002313.57,DR=".01///@" D ^DIE
K ^ABSPTL("NON-FILEMAN")
Q
57 ;EP - 9002313.57 Billing
; AGE("WINNOW .57 AFTER POSTING") - if you have ILC A/R, then delete
; a .57 entry this many days after posting, if account has 0
; balance. Recommended 400.
; AGE("WINNOW UNPOSTED .57") - non ILC A/R or missed posting ILC A/R
; Delete this many days after last update.
; Recommended 100, though there shouldn't be a problem with 0, even.
I 'AGE("WINNOW .57 AFTER POSTING") S AGE("WINNOW .57 AFTER POSTING")=400
I 'AGE("WINNOW UNPOSTED .57") S AGE("WINNOW UNPOSTED .57")=100
N BILLTHRU S BILLTHRU=$$BILLTHRU
N IFACE57 S IFACE57=$$IFACE57
; BILLTHRU = which transaction # we've billed through
; If there's no billing interface, then we say we've billed it all.
I IFACE57 S BILLTHRU=$$BILLTHRU
E S BILLTHRU=$P(^ABSPTL(0),U,3)
;
I IEN>BILLTHRU Q ; still need this one for billing
N LUPDATE S LUPDATE=$$GET1^DIQ(9002313.57,IEN_",",7,"I") ; LAST UPDATE
N ISPOSTED S ISPOSTED=$$GET1^DIQ(9002313.57,IEN_",",2,"I")
I ISILCAR D ; use the date the bill was created, instead
. N PCNDFN S PCNDFN=$$GET1^DIQ(9002313.57,IEN_",",2,"I")
. Q:'PCNDFN
. N % S %=$$GET1^DIQ(9002302,PCNDFN_",",2.8)
. I % S LUPDATE=%
I 'LUPDATE D SETTODAY(9002313.57,7) Q
N DELFLAG
I ISPOSTED D
. S DELFLAG=$$AGE(LUPDATE)>AGE("WINNOW .57 AFTER POSTING")&ISPOSTED
E D
. S DELFLAG=$$AGE(LUPDATE)>AGE("WINNOW UNPOSTED .57")
I DELFLAG D DELETE(9002313.57,IEN)
Q
BILLTHRU() ; through what transaction # have we billed?
; meaningful only for ILC and IHS a/r interfaces
Q $$GET1^DIQ(9002313.99,"1,",230.01)
IFACE57() ; true if you have a billing interface w/9002313.57
Q $$DOINGAR^ABSPOSB
59 ;EP - 9002313.59 Working
; Let's keep them around for a year - someone might need to
; set view to One Patient and call up something old
I 'AGE("WINNOW .59") S AGE("WINNOW .59")=366
N X S X=$P(^ABSPT(IEN,0),U,8)
I 'X D Q ; stuff
. D LOG("Setting current date into 9002313.59 IEN="_N)
. N FDA,MSG S FDA(9002313.59,IEN_",",7)=NOW D FILE^DIE("E","FDA","MSG")
. I $D(MSG) D LOG^ABSPOSL2("59^ABSPOSK1",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
I $$AGE(X)>AGE("WINNOW .59") D DELETE(9002313.59,IEN)
Q
LOGFILES ;EP - ^ABSPECP("LOG",IEN,
; AGE("WINNOW LOG FILES") - this many days following the most recent
; write to the file - recommended 90; could be as low as you want
I 'AGE("WINNOW LOG FILES") S AGE("WINNOW LOG FILES")=90
N D S D=$P($G(^ABSPECP("LOG",IEN)),U,3)
I 'D S D=$P($G(^ABSPECP("LOG",IEN)),U)
I 'D S $P(^ABSPECP("LOG",IEN),U)=$H Q ; no date - give it today's
; and it will be deleted at some later date
; unusual case with log files - it's a $H date - must convert it
;
; IHS/SD/lwj 04/03/02 changed D to equal the date and seconds
D
. ;N %H,%,X S %H=D D YMD^%DTC S D=% ;IHS/SD/lwj 04/03/02 rem out
. N %H,%,X S %H=D D YMD^%DTC S D=X+% ;IHS/SD/lwj 04/03/02 D chgd
N DELFLAG S DELFLAG=0
I $$AGE(D)>AGE("WINNOW LOG FILES") S DELFLAG=1
I DELFLAG D
. N MSG S MSG=$S(TESTING:"We would delete",1:"Deleting")_" log file "
. S MSG=MSG_IEN
. D LOG(MSG)
. D DELLOG(IEN)
Q
COMBINS ;EP - ^ABSPCOMB(IEN,
; AGE("WINNOW COMBINED INSURANCE") - this many days following the
; completion of most recent 9002313.57 transaction
; Slight risk of conflict if you're deleting the record just as
; the next prescription for this patient is being processed.
I 'AGE("WINNOW COMBINED INSURANCE") D
. S AGE("WINNOW COMBINED INSURANCE")=100
N PAT S PAT=$P(^ABSPCOMB(IEN,0),U)
; when was the last completed transaction for this patient?
N N57 S N57=$O(^ABSPTL("AC",PAT,""),-1)
N DELFLAG S DELFLAG=0
I 'N57 S DELFLAG=1 ; no record of patient in completed transactions
E D ; look at most recently-completed transaction's LAST UPDATE
. N LUPDATE S LUPDATE=$P(^ABSPTL(N57,0),U,8)
. I $$AGE(LUPDATE)>AGE("WINNOW COMBINED INSURANCE") S DELFLAG=1
I DELFLAG D DELETE(9002313.1,IEN)
Q
LOG(X) D LOG^ABSPOSL(X) Q
AGE(X2) ; given fileman date/time, how many days old is it?
N X1,X,%Y
S X2=$P(X2,"."),X1=$$TODAY
D ^%DTC
Q X
TODAY() N %,%H,%I,X D NOW^%DTC Q $P(%,".")
SETTODAY(FILE,IENS,FIELD) ; the given FILE, FIELD is missing a date, unexpectedly
; set today's date in there, so that it will be winnowed at some time
; in the future
N FDA
S:IENS'?.E1"," IENS=IENS_","
D LOG("Missing date; stuffed today into FILE="_FILE_",IENS="_IENS_",FIELD="_FIELD)
S FDA(FILE,IENS,FIELD)=$$TODAY
ST5 D FILE^DIE(,"FDA","MSG")
I $D(MSG) D LOG^ABSPOSL2("ST5^ABSPOSK1",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
Q:'$D(MSG) ; success
D ZWRITE^ABSPOS("MSG")
G ST5:$$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"SETTODAY",$T(+0))
Q
DELETE(FILE,IENS) ; this is where it happens!!!
S:IENS'?.E1"," IENS=IENS_","
;
; Never delete the highest #d entry in a file.
; Prevent the re-use of IENs.
;
Q:$$HIGHEST
;
; Do the delete:
N FDA
N MSG S MSG=$S(TESTING:"We would delete",1:"DELETING")
S MSG=MSG_" FILE="_FILE_",IENS="_IENS
D LOG(MSG)
K MSG
S FDA(FILE,IENS,.01)=""
Q:TESTING
DE5 D FILE^DIE(,"FDA","MSG")
I $D(MSG) D LOG^ABSPOSL2("DE5^ABSPOSK1",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
I $D(MSG) D ZWRITE^ABSPOS("FDA","MSG") G DE5:$$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"DELETE",$T(+0))
; Make sure the deletion worked: fetch the .01 field
I $$GET1^DIQ(FILE,IENS,.01)]"" G DE5:$$IMPOSS^ABSPOSUE("FM","TRI","deletion failed",,"DELETE",$T(+0))
Q
HIGHEST() ; is IENS the highest #d top-level entry in FILE?
I $L(IENS,",")>2 Q 0
N ROOT S ROOT=$$ROOT^DILFD(FILE,",",1)
Q '$O(@ROOT@(+IENS))
DELFIELD(FILE,IENS,FIELD) ; and here too
N FDA
S:IENS'?.E1"," IENS=IENS_","
N MSG S MSG=$S(TESTING:"We would delete",1:"DELETING")
S MSG=MSG_" FILE="_FILE_",IENS="_IENS_",FIELD="_FIELD
D LOG(MSG)
K MSG
S FDA(FILE,IENS,FIELD)=""
I 'TESTING D FILE^DIE(,"FDA","MSG") I $D(MSG) D LOG^ABSPOSL2("DELFIELD^ABSPOSK1",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
Q
DELLOG(N) ; special for log files
N MSG S MSG=$S(TESTING:"We would delete",1:"DELETING")
S MSG=MSG_" Log file "_N
D LOG(MSG)
K MSG
I 'TESTING K ^ABSPECP("LOG",N)
Q
ABSPOSK1 ; IHS/FCS/DRS - winnow POS data ; [ 04/03/2002 10:05 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**1,48,49**;JUN 21, 2001;Build 38
+2 QUIT
+3 ;
+4 ; IHS/SD/lwj 04/03/02 as per David's fix at ANMC - changed
+5 ; the check date so that it represents the date and time
+6 ; Without this fix, the log files are not being deleted properly.
+7 ; One change made to the "D" field in the LOGFILES subroutine.
+8 ;
+9 ; Contains the routines to evaluate one given entry
+10 ; The IEN is given to each one. Called from loops in ABSPOSK
+11 ; Also passed in here: AGE(*) array, BILLSYS
03 ;EP - 9002313.03 Responses
+1 NEW X,CLAIM,RECD
SET X=^ABSPR(IEN,0)
SET CLAIM=$PIECE(X,U)
SET RECD=$PIECE(X,U,2)
+2 IF 'AGE("WINNOW .03 RAW DATA")
SET AGE("WINNOW .03 RAW DATA")=30
+3 IF 'AGE("WINNOW .03 CONTENTS")
SET AGE("WINNOW .03 CONTENTS")=366
+4 ; The raw copy of the packet doesn't have to be kept around very
+5 ; long - it's only there for diagnostic purposes; rarely used.
+6 IF $$AGE(RECD)>AGE("WINNOW .03 RAW DATA")
Begin DoDot:1
+7 IF $DATA(^ABSPR(IEN,"M"))
DO DELFIELD(9002313.03,IEN,9999)
End DoDot:1
+8 ; The contents should stick around awhile longer.
+9 ; In addition, if we're using the A/R interface, also require
+10 ; that the charge have been posted and that the bill have
+11 ; a zero balance.
+12 IF ISILCAR
IF '$$CLOSED02(CLAIM)
QUIT
+13 ; no delete if pointed to by transaction
IF $$PT5759(3)
QUIT
+14 IF $$AGE02(CLAIM)>AGE("WINNOW .03 CONTENTS")
DO DELETE(9002313.03,IEN)
+15 QUIT
02 ;EP - 9002313.02 Claims
+1 ; Use the transmit date if it's there; otherwise the create date.
+2 IF 'AGE("WINNOW .02 RAW DATA")
SET AGE("WINNOW .02 RAW DATA")=30
+3 IF 'AGE("WINNOW .02 CONTENTS")
SET AGE("WINNOW .02 CONTENTS")=366
+4 ; Raw copy of the packet can be short-lived
+5 IF $$AGE02(IEN)>AGE("WINNOW .02 RAW DATA")
Begin DoDot:1
+6 IF $DATA(^ABSPC(IEN,"M"))
DO DELFIELD(9002313.02,IEN,9999)
End DoDot:1
+7 ; If using ILC A/R interface, also require that the charges have
+8 ; been posted and that the bill have a zero balance.
+9 IF ISILCAR
IF '$$CLOSED02(IEN)
QUIT
+10 ; no delete if pointed to by transaction
IF $$PT5759(2)
QUIT
+11 ; no delete if pointed to by .03
IF $ORDER(^ABSPR("B",IEN,0))
QUIT
+12 IF $$AGE02(IEN)>AGE("WINNOW .02 CONTENTS")
DO DELETE(9002313.02,IEN)
+13 QUIT
PT5759(F) ; does any 9002313.57 or 9002313.59 point to this claim or resp. IEN
+1 ; IEN points to the 9002313.02 or 9002313.03, too
+2 ; F = 2 for claims, F=3 for responses
+3 NEW RET,INDEX,FF
SET RET=0
+4 IF F=2
Begin DoDot:1
+5 FOR INDEX="AE","AER"
FOR FF=9002313.57,9002313.59
Begin DoDot:2
+6 IF FF=9002313.57
IF $ORDER(^ABSPTL(INDEX,IEN,0))
SET RET=1
+7 IF FF=9002313.59
IF $ORDER(^ABSPT(INDEX,IEN,0))
SET RET=1
End DoDot:2
End DoDot:1
+8 IF '$TEST
IF F=3
Begin DoDot:1
+9 FOR INDEX="AF","AFR"
FOR FF=9002313.57,9002313.59
Begin DoDot:2
+10 IF FF=9002313.57
IF $ORDER(^ABSPTL(INDEX,IEN,0))
SET RET=1
+11 IF FF=9002313.59
IF $ORDER(^ABSPT(INDEX,IEN,0))
SET RET=1
End DoDot:2
End DoDot:1
+12 IF '$TEST
DO IMPOSS^ABSPOSUE("P","TI","Bad arg F="_F,,"PT5759",$TEXT(+0))
+13 QUIT RET
AGE02(N) ; how old is the 9002313.02 entry?
+1 ; if dates are totally missing, it inserts a date
+2 ; Use transmit date if it's there; otherwise created date
+3 NEW X,Y
SET X=^ABSPC(N,0)
+4 SET Y=$PIECE(X,U,5)
IF 'Y
SET Y=$PIECE(X,U,6)
IF 'Y
Begin DoDot:1
+5 DO LOG("Setting current date into 9002313.02 IEN="_N)
AG5 NEW FDA,MSG
SET FDA(9002313.02,N_",",.06)="NOW"
+1 DO FILE^DIE("E","FDA","MSG")
+2 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("AG5^ABSPOSK1",.MSG)
+3 IF $DATA(MSG)
IF $$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"AGE02",$TEXT(+0))
GOTO AG5
+4 SET Y=$$GET1^DIQ(9002313.02,N_",",.06,"I")
End DoDot:1
IF Y
QUIT 0
QUIT $$IMPOSS^ABSPOSUE("DB","TI","Unable to store dates into ^ABSPC("_N,,"AGE02",$TEXT(+0))
+5 QUIT $$AGE(Y)
CLOSED02(N) ; is ^ABSPC(N,... posted to A/R and with a zero balance?
+1 ; ILC A/R only !!! This code is not reached for other A/R types
+2 ; (also returns true if the .02 is unposted for over a year)
+3 NEW PCN,BBLIMIT
SET PCN=$PIECE(^ABSPC(N,0),U,3)
+4 ; true if zero balance
IF PCN
QUIT '$GET(^ABSBITMS(9002302,PCN,3),U)
+5 ; not posted - is it over a year old?
+6 ; Q $$AGE02(N)>365
+7 ; /IHS/OIT/RAM ; 16 OCT 2017 ; CR#09828 Changes the amount of time we can back-bill payers; change
+8 ; 1 year limit to a new field in the ABSP SETUP file with that parameter. Default is now 6 years.
+9 ; S BBLIMIT=+$G(^ABSP(9002313.99,1,"BACKLIMIT")) ; Grab default from ABSP SETUP file.
+10 ; I BBLIMIT=0 S BBLIMIT=2192 ; If there is no value, set it to 6 years (in days).
+11 ; 31 OCT 17 ; CR 9828 IS NOW ON HOLD; CHANGE BACK TO ORIGINAL 1 YEAR BEHAVIOUR.
SET BBLIMIT=365
+12 ; Return 1 if within the time limit, 0 otherwise.
QUIT $$AGE02(N)>BBLIMIT
+13 ; /IHS/OIT/RAM ; 16 OCT 2017 ; END OF CHANGES FOR CR#09828
51 ;EP - 9002313.51 Input
+1 ; a month is more than enough
+2 IF 'AGE("WINNOW .51")
SET AGE("WINNOW .51")=31
+3 IF $$AGE($PIECE(^ABSP(9002313.51,IEN,0),U))>AGE("WINNOW .51")
Begin DoDot:1
+4 DO DELETE(9002313.51,IEN)
End DoDot:1
+5 QUIT
511 ;EP - 9002313.511 Override
+1 IF 'AGE("WINNOW .511")
SET AGE("WINNOW .511")=366
+2 IF $$AGE($PIECE(^ABSP(9002313.51,IEN,0),U,2))>AGE("WINNOW .511")
Begin DoDot:1
+3 DO DELETE(9002313.511,IEN)
End DoDot:1
+4 QUIT
ALL57 ;EP - temporary - development use
+1 NEW DA
FOR
SET DA=$ORDER(^ABSPTL(0))
IF 'DA
QUIT
Begin DoDot:1
+2 SET DIE=9002313.57
SET DR=".01///@"
DO ^DIE
End DoDot:1
+3 KILL ^ABSPTL("NON-FILEMAN")
+4 QUIT
57 ;EP - 9002313.57 Billing
+1 ; AGE("WINNOW .57 AFTER POSTING") - if you have ILC A/R, then delete
+2 ; a .57 entry this many days after posting, if account has 0
+3 ; balance. Recommended 400.
+4 ; AGE("WINNOW UNPOSTED .57") - non ILC A/R or missed posting ILC A/R
+5 ; Delete this many days after last update.
+6 ; Recommended 100, though there shouldn't be a problem with 0, even.
+7 IF 'AGE("WINNOW .57 AFTER POSTING")
SET AGE("WINNOW .57 AFTER POSTING")=400
+8 IF 'AGE("WINNOW UNPOSTED .57")
SET AGE("WINNOW UNPOSTED .57")=100
+9 NEW BILLTHRU
SET BILLTHRU=$$BILLTHRU
+10 NEW IFACE57
SET IFACE57=$$IFACE57
+11 ; BILLTHRU = which transaction # we've billed through
+12 ; If there's no billing interface, then we say we've billed it all.
+13 IF IFACE57
SET BILLTHRU=$$BILLTHRU
+14 IF '$TEST
SET BILLTHRU=$PIECE(^ABSPTL(0),U,3)
+15 ;
+16 ; still need this one for billing
IF IEN>BILLTHRU
QUIT
+17 ; LAST UPDATE
NEW LUPDATE
SET LUPDATE=$$GET1^DIQ(9002313.57,IEN_",",7,"I")
+18 NEW ISPOSTED
SET ISPOSTED=$$GET1^DIQ(9002313.57,IEN_",",2,"I")
+19 ; use the date the bill was created, instead
IF ISILCAR
Begin DoDot:1
+20 NEW PCNDFN
SET PCNDFN=$$GET1^DIQ(9002313.57,IEN_",",2,"I")
+21 IF 'PCNDFN
QUIT
+22 NEW %
SET %=$$GET1^DIQ(9002302,PCNDFN_",",2.8)
+23 IF %
SET LUPDATE=%
End DoDot:1
+24 IF 'LUPDATE
DO SETTODAY(9002313.57,7)
QUIT
+25 NEW DELFLAG
+26 IF ISPOSTED
Begin DoDot:1
+27 SET DELFLAG=$$AGE(LUPDATE)>AGE("WINNOW .57 AFTER POSTING")&ISPOSTED
End DoDot:1
+28 IF '$TEST
Begin DoDot:1
+29 SET DELFLAG=$$AGE(LUPDATE)>AGE("WINNOW UNPOSTED .57")
End DoDot:1
+30 IF DELFLAG
DO DELETE(9002313.57,IEN)
+31 QUIT
BILLTHRU() ; through what transaction # have we billed?
+1 ; meaningful only for ILC and IHS a/r interfaces
+2 QUIT $$GET1^DIQ(9002313.99,"1,",230.01)
IFACE57() ; true if you have a billing interface w/9002313.57
+1 QUIT $$DOINGAR^ABSPOSB
59 ;EP - 9002313.59 Working
+1 ; Let's keep them around for a year - someone might need to
+2 ; set view to One Patient and call up something old
+3 IF 'AGE("WINNOW .59")
SET AGE("WINNOW .59")=366
+4 NEW X
SET X=$PIECE(^ABSPT(IEN,0),U,8)
+5 ; stuff
IF 'X
Begin DoDot:1
+6 DO LOG("Setting current date into 9002313.59 IEN="_N)
+7 NEW FDA,MSG
SET FDA(9002313.59,IEN_",",7)=NOW
DO FILE^DIE("E","FDA","MSG")
+8 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("59^ABSPOSK1",.MSG)
End DoDot:1
QUIT
+9 IF $$AGE(X)>AGE("WINNOW .59")
DO DELETE(9002313.59,IEN)
+10 QUIT
LOGFILES ;EP - ^ABSPECP("LOG",IEN,
+1 ; AGE("WINNOW LOG FILES") - this many days following the most recent
+2 ; write to the file - recommended 90; could be as low as you want
+3 IF 'AGE("WINNOW LOG FILES")
SET AGE("WINNOW LOG FILES")=90
+4 NEW D
SET D=$PIECE($GET(^ABSPECP("LOG",IEN)),U,3)
+5 IF 'D
SET D=$PIECE($GET(^ABSPECP("LOG",IEN)),U)
+6 ; no date - give it today's
IF 'D
SET $PIECE(^ABSPECP("LOG",IEN),U)=$HOROLOG
QUIT
+7 ; and it will be deleted at some later date
+8 ; unusual case with log files - it's a $H date - must convert it
+9 ;
+10 ; IHS/SD/lwj 04/03/02 changed D to equal the date and seconds
+11 Begin DoDot:1
+12 ;N %H,%,X S %H=D D YMD^%DTC S D=% ;IHS/SD/lwj 04/03/02 rem out
+13 ;IHS/SD/lwj 04/03/02 D chgd
NEW %H,%,X
SET %H=D
DO YMD^%DTC
SET D=X+%
End DoDot:1
+14 NEW DELFLAG
SET DELFLAG=0
+15 IF $$AGE(D)>AGE("WINNOW LOG FILES")
SET DELFLAG=1
+16 IF DELFLAG
Begin DoDot:1
+17 NEW MSG
SET MSG=$SELECT(TESTING:"We would delete",1:"Deleting")_" log file "
+18 SET MSG=MSG_IEN
+19 DO LOG(MSG)
+20 DO DELLOG(IEN)
End DoDot:1
+21 QUIT
COMBINS ;EP - ^ABSPCOMB(IEN,
+1 ; AGE("WINNOW COMBINED INSURANCE") - this many days following the
+2 ; completion of most recent 9002313.57 transaction
+3 ; Slight risk of conflict if you're deleting the record just as
+4 ; the next prescription for this patient is being processed.
+5 IF 'AGE("WINNOW COMBINED INSURANCE")
Begin DoDot:1
+6 SET AGE("WINNOW COMBINED INSURANCE")=100
End DoDot:1
+7 NEW PAT
SET PAT=$PIECE(^ABSPCOMB(IEN,0),U)
+8 ; when was the last completed transaction for this patient?
+9 NEW N57
SET N57=$ORDER(^ABSPTL("AC",PAT,""),-1)
+10 NEW DELFLAG
SET DELFLAG=0
+11 ; no record of patient in completed transactions
IF 'N57
SET DELFLAG=1
+12 ; look at most recently-completed transaction's LAST UPDATE
IF '$TEST
Begin DoDot:1
+13 NEW LUPDATE
SET LUPDATE=$PIECE(^ABSPTL(N57,0),U,8)
+14 IF $$AGE(LUPDATE)>AGE("WINNOW COMBINED INSURANCE")
SET DELFLAG=1
End DoDot:1
+15 IF DELFLAG
DO DELETE(9002313.1,IEN)
+16 QUIT
LOG(X) DO LOG^ABSPOSL(X)
QUIT
AGE(X2) ; given fileman date/time, how many days old is it?
+1 NEW X1,X,%Y
+2 SET X2=$PIECE(X2,".")
SET X1=$$TODAY
+3 DO ^%DTC
+4 QUIT X
TODAY() NEW %,%H,%I,X
DO NOW^%DTC
QUIT $PIECE(%,".")
SETTODAY(FILE,IENS,FIELD) ; the given FILE, FIELD is missing a date, unexpectedly
+1 ; set today's date in there, so that it will be winnowed at some time
+2 ; in the future
+3 NEW FDA
+4 IF IENS'?.E1","
SET IENS=IENS_","
+5 DO LOG("Missing date; stuffed today into FILE="_FILE_",IENS="_IENS_",FIELD="_FIELD)
+6 SET FDA(FILE,IENS,FIELD)=$$TODAY
ST5 DO FILE^DIE(,"FDA","MSG")
+1 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("ST5^ABSPOSK1",.MSG)
+2 ; success
IF '$DATA(MSG)
QUIT
+3 DO ZWRITE^ABSPOS("MSG")
+4 IF $$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"SETTODAY",$TEXT(+0))
GOTO ST5
+5 QUIT
DELETE(FILE,IENS) ; this is where it happens!!!
+1 IF IENS'?.E1","
SET IENS=IENS_","
+2 ;
+3 ; Never delete the highest #d entry in a file.
+4 ; Prevent the re-use of IENs.
+5 ;
+6 IF $$HIGHEST
QUIT
+7 ;
+8 ; Do the delete:
+9 NEW FDA
+10 NEW MSG
SET MSG=$SELECT(TESTING:"We would delete",1:"DELETING")
+11 SET MSG=MSG_" FILE="_FILE_",IENS="_IENS
+12 DO LOG(MSG)
+13 KILL MSG
+14 SET FDA(FILE,IENS,.01)=""
+15 IF TESTING
QUIT
DE5 DO FILE^DIE(,"FDA","MSG")
+1 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("DE5^ABSPOSK1",.MSG)
+2 IF $DATA(MSG)
DO ZWRITE^ABSPOS("FDA","MSG")
IF $$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"DELETE",$TEXT(+0))
GOTO DE5
+3 ; Make sure the deletion worked: fetch the .01 field
+4 IF $$GET1^DIQ(FILE,IENS,.01)]""
IF $$IMPOSS^ABSPOSUE("FM","TRI","deletion failed",,"DELETE",$TEXT(+0))
GOTO DE5
+5 QUIT
HIGHEST() ; is IENS the highest #d top-level entry in FILE?
+1 IF $LENGTH(IENS,",")>2
QUIT 0
+2 NEW ROOT
SET ROOT=$$ROOT^DILFD(FILE,",",1)
+3 QUIT '$ORDER(@ROOT@(+IENS))
DELFIELD(FILE,IENS,FIELD) ; and here too
+1 NEW FDA
+2 IF IENS'?.E1","
SET IENS=IENS_","
+3 NEW MSG
SET MSG=$SELECT(TESTING:"We would delete",1:"DELETING")
+4 SET MSG=MSG_" FILE="_FILE_",IENS="_IENS_",FIELD="_FIELD
+5 DO LOG(MSG)
+6 KILL MSG
+7 SET FDA(FILE,IENS,FIELD)=""
+8 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF 'TESTING
DO FILE^DIE(,"FDA","MSG")
IF $DATA(MSG)
DO LOG^ABSPOSL2("DELFIELD^ABSPOSK1",.MSG)
+9 QUIT
DELLOG(N) ; special for log files
+1 NEW MSG
SET MSG=$SELECT(TESTING:"We would delete",1:"DELETING")
+2 SET MSG=MSG_" Log file "_N
+3 DO LOG(MSG)
+4 KILL MSG
+5 IF 'TESTING
KILL ^ABSPECP("LOG",N)
+6 QUIT
