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

ABSPOSPW.m

Go to the documentation of this file. 
  1. ABSPOSPW ; IHS/FCS/DRS - automatic writeoffs - criteria on form ;    [ 09/12/2002  10:18 AM ]
  1.  ;;1.0;PHARMACY POINT OF SALE;**3**;JUN 21, 2001;Build 38
  1.  Q
  1. PARAMS ; used as a header
  1.  ;N (U,DT,DUZ,IOM,PARAMS) ;
  1.  N FN,DIC,DR,DA,DIQ,ARR,X,DI,Y
  1.  S (FN,DIC)=9002313.99,DR="2270:2280",DA=1,DIQ="ARR",DIQ(0)="IE"
  1.  D EN^DIQ1
  1.  S X=$G(ARR(FN,1,2270.01,"E"))
  1.  I X'?1"ALL".E D
  1.  . W "Insurers: ",X,":   "
  1.  . D PARAMS1("INS","^AUTNINS")
  1.  S X=$G(ARR(FN,1,2270.02,"E"))
  1.  I X'?1"ALL".E D
  1.  . W "A/R types: ",X,":   "
  1.  . D PARAMS1("ARTYP","^ABSBTYP")
  1.  S X=$G(ARR(FN,1,2270.06,"E"))
  1.  I X'?1"ALL".E D
  1.  . W "Clinics: ",X,":   "
  1.  . D PARAMS1("CLINIC","^DIC(40.7)")
  1.  S X=$G(ARR(FN,1,2270.7,"E"))
  1.  I X'?1"ALL".E D
  1.  . W "Primary diagnosis: ",X,":   "
  1.  . D PARAMS1("DIAG","^ICD9")
  1.  W "Balances from $",$J($P(PARAMS,U,3),0,2)
  1.  W " thru $",$J($P(PARAMS,U,4),0,2),"; "
  1.  I $P(PARAMS,U,9) W "no more than ",$P(PARAMS,U,9),"% of original amount.",!
  1.  W "Account age over ",$P(PARAMS,U,5)," days;  "
  1.  W "Date of service no later than " S Y=$P(PARAMS,U,8) X ^DD("DD") W Y,!
  1.  W "Writeoff reason to put with adjustment: ",$G(ARR(FN,1,2270.12,"E")),!
  1.  S X=$G(ARR(FN,1,2270.11,"E"))
  1.  I X'="DON'T CONSIDER" W "Previous payment required: ",X,!
  1.  Q
  1. PARAMS1(SUB,ROOT)  ; $P(PARAMS(SUB,"B",*),U) points to ROOT
  1.  N A S A=0
  1.  F  S A=$O(PARAMS(SUB,"B",A)) Q:'A  D
  1.  . N X S X=$P(@ROOT@(A,0),U)
  1.  . I $X+$L(X)'<$S($G(IOM):IOM-2,1:80-2) W !?5
  1.  . W X
  1.  . I $O(PARAMS(SUB,A)) W ", "
  1.  . E  W !
  1.  I $X>0 W !
  1.  Q
  1. TEMPLNAM(WHICH)    ; WHICH="SORT" or "PRINT"
  1.  I WHICH="PRINT" Q "ABSPOSPW"
  1.  D IMPOSS^ABSPOSUE("P","TI","Bad parameter WHICH="_WHICH,,"TEMPLNAM",$T(+0))
  1.  Q ""
  1. TEMPLNUM(WHICH)    ;
  1.  N NAME S NAME=$$TEMPLNAM(WHICH)
  1.  I WHICH="SORT" Q $O(^DIBT("B",NAME,0))
  1.  I WHICH="PRINT" Q $O(^DIPT("B",NAME,0))
  1.  D IMPOSS^ABSPOSUE("P","TI","Bad parameter WHICH="_WHICH,,"TEMPLNUM",$T(+0))
  1.  Q ""
  1.  K ^TMP($J,ROU) S ^TMP($J,ROU)=0
  1.  N L S L="<THIS SHOULDN'T PRINT>"
  1.  N DIC S DIC=9002302
  1.  N FLDS S FLDS="["_$$TEMPLNAM("PRINT")_"]"
  1.  N BY S BY="2,1,@2.8" ;audit insurer, patient, date created ;"["_$$TEMPLNAM("SORT")_"]"
  1.  N FR,TO S (FR,TO)=""
  1.  N DHD S DHD="W ?0 D PARAMS^"_$T(+0)
  1.  N DIASKHD,DIPCRIT,PG ; keep these undef
  1.  N DHIT S DHIT="S ^TMP($J,ROU,D0)="""",^TMP($J,ROU)=^TMP($J,ROU)+1"
  1.  N DIOEND,DCOPIES,IOP,DQTIME ; keep these undef
  1.  N DIS S DIS(0)="I $$INCLUDE^ABSPOSPX" ; screening
  1.  N DISUPNO,DISTOP ; keep these undef
  1.  S BY(0)="^ABSBITMS(9002302,""AF"",",L(0)=2
  1.  S (FR(0,1),TO(0,1))="A" ; only the active accounts
  1.  ;W !,"This is where we call DO EN1^DIP",!
  1.  N NINCLUDE S NINCLUDE=0
  1.  D EN1^DIP
  1.  ;W !,"returned from DO EN1^DIP",!
  1.  Q
  1. EN ;EP - option ABSP WRITEOFF SELECTION
  1.  Q:$$MUSTILC^ABSPOSB
  1.  N ACTIVBAT S ACTIVBAT=$$ACTIVBAT^ABSPOSPX I ACTIVBAT D  H 2 Q
  1.  . W !!,"Batch #",ACTIVBAT," must be dealt with first.",!
  1.  . W "Either post the batch (BE SURE THAT'S REALLY WHAT YOU WANT TO DO!),",!
  1.  . W "or cancel the batch, before running this program to create a new batch.",!
  1.  N ROU S ROU=$T(+0)
  1.  N X D
  1.  . N LOCKREF S LOCKREF="^ABSP(9002313.99,1,""WRITEOFF-SCREEN"")"
  1.  . L +@LOCKREF:0 I '$T D  S X="" Q
  1.  . . W "Someone else is using the Writeoffs program now.",!
  1.  . S X=$$MYSCREEN
  1.  . I X S X=$G(^ABSP(9002313.99,1,"WRITEOFF-SCREEN"))
  1.  . E  S X=""
  1.  . L -@LOCKREF
  1.  I X="" W "Nothing done",! H 2 Q  ; didn't get <F1>E
  1.  N PARAMS M PARAMS=^ABSP(9002313.99,1,"WRITEOFF-SCREEN")
  1.  M PARAMS("INS")=^ABSP(9002313.99,1,"WRITEOFF-SCREEN INSURER")
  1.  M PARAMS("ARTYP")=^ABSP(9002313.99,1,"WRITEOFF-SCREEN ARTYPE")
  1.  M PARAMS("CLINIC")=^ABSP(9002313.99,1,"WRITEOFF-SCREEN CLINIC")
  1.  M PARAMS("DIAG")=^ABSP(9002313.99,1,"WRITEOFF-SCREEN DIAG")
  1.  ;
  1.  D  ; all we want are the "B" indexes of the merged lists
  1.  . N A S A="" F  S A=$O(PARAMS(A)) Q:A=""  D
  1.  . . N B S B="" F  S B=$O(PARAMS(A,B)) Q:B=""  K:B'="B" PARAMS(A,B)
  1.  ;D PARAMS R ">>>",% ; temporary!
  1.  ; If the age of account has been specified, calculate now the
  1.  ; aging date, going back N+1 days
  1.  I $P(PARAMS,U,5) S PARAMS("AGING DATE < THIS")=$$AGECALC
  1.  W !!,"Choose a device for printing a list of the accounts",!
  1.  W "which meet the criteria you've just specified.",!?5
  1.  D SEARCH ; EN1^DIP calls the printing, too
  1.  I '^TMP($J,ROU) D  Q
  1.  . W !,"NO accounts match the given criteria.",!
  1.  W !,"Number of accounts found: ",^TMP($J,ROU),!
  1.  I '$$DOBATCH Q
  1.  ; and we just have to apply it to the list in ^TMP($J,ROU,*)
  1.  W !,"Creating the adjustments batch...",!
  1.  N BATCH S BATCH=$$NEWBATCH^ABSPOSP(1)
  1.  I 'BATCH W "FAILED",! Q
  1.  W "The batch number is ",BATCH,!
  1.  S $P(^ABSP(9002313.99,1,"WRITEOFF-SCREEN BATCH"),U)=BATCH
  1.  N PCNDFN S PCNDFN=0
  1.  N REASON S REASON=$P(PARAMS,U,12)
  1.  I REASON?1N.N S REASON=$P(^ABSADJR(9002320,REASON,0),U,2)
  1.  I REASON="" S REASON="(from write-off selection screen)"
  1.  F  S PCNDFN=$O(^TMP($J,ROU,PCNDFN)) Q:'PCNDFN  D
  1.  . N BAL S BAL=$P(^ABSBITMS(9002302,PCNDFN,3),U)
  1.  . D ADJUST^ABSPOSP(PCNDFN,BATCH,BAL,REASON)
  1.  . W "." W:$X>70 !
  1.  W !!
  1.  W "Batch ",BATCH," has been created.",!
  1.  W "You should inspect it SOON and either POST it or CANCEL it.",!
  1.  W "Either way, take care of it BEFORE running this program again.",!
  1.  W "This is to avoid the situation of generating more than one",!
  1.  W "writeoff adjustment for any accounts.",!!
  1.  D PRESSANY^ABSPOSU5()
  1.  Q
  1. DOBATCH()          ; 
  1.  N PROMPT,DEFAULT,OPT,TIMEOUT
  1.  S PROMPT="Create an ADJUSTMENTS BATCH for these write-offs now?"
  1.  S DEFAULT="NO"
  1.  S OPT=0
  1.  S TIMEOUT=3600*72 ; the kind of thing you might start then go home
  1.  N X S X=$$YESNO^ABSPOSU3(PROMPT,DEFAULT,OPT,TIMEOUT)
  1.  Q +X
  1. AGECALC()          ; 
  1.  N X1 S X1=$P($$NOW,".")
  1.  N X2 S X2=-$P(PARAMS,U,5)
  1.  N X,%H D C^%DTC
  1.  Q X
  1. NOW() N %,%H,%I,X D NOW^%DTC Q %
  1. MYSCREEN()       ; returns 1 if <F1>E (or the equivalent) was used
  1.  ; if the user quits out (<F1>Q or the equivalent), returns 0
  1.  N DDSFILE,DR,DDSPAGE,DDSPARM
  1.  N DDSCHANG,DDSSAVE,DIMSG,DTOUT
  1.  N DA
  1.  S DDSFILE=9002313.99,DA=1
  1.  S DR="[ABSP ABSPOSPW]"
  1.  S DDSPARM="CS"
  1.  D ^DDS
  1.  Q:'$Q
  1.  I $G(DDSSAVE) Q 1
  1.  E  Q 0