Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ABSPOSK1

ABSPOSK1.m

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