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