ABSPOSM1 ; IHS/FCS/DRS - build Report Master data ; [ 09/12/2002 10:12 AM ]
;;1.0;PHARMACY POINT OF SALE;**3,9,31,32,36,48**;JUN 21, 2001;Build 38
Q
;
; File 9002313.61 - ABSP REPORT MASTER
; Purpose: make it easy to use Fileman to get data,
; by storing pointers to various places, indexed by Release Date
;
;----------------------------------------------------------
; IHS/SD/lwj 2/5/04 patch 9 logic added to CLEAN61 to
; avoid missing RXI and RXR pointers. (?? not sure why
; they are missing - and they are only missing at Santa Fe.
; Without the RX to reference, it's almost impossible to
; track down.)
;
;----------------------------------------------------------
;
UPDATE61(BEGINDT,ENDDT,SILENT) ; EP - update the .61 file.
; If called with $$, returns 1 success, 0 failure
I '$D(SILENT) S SILENT=0
I 'SILENT W !! D LASTRUN
I '$$LOCK61 D Q:$Q 0 Q
. I 'SILENT W !,"Someone else is already using this program.",!
I '$D(BEGINDT) D I '$D(BEGINDT) Q:$Q 0 Q
. N X
. W !,"Choose the date range of prescription RELEASE DATE",!
. W "to include in this report.",!
. S X=$$DTR^ABSPOSU1("Starting at date@time: ","Thru date@time: ",,,"T")
. Q:'X
. S BEGINDT=$P(X,U),ENDDT=$P(X,U,2)
I '$D(ENDDT) S ENDDT=BEGINDT
I $P(ENDDT,".",2)="" S $P(ENDDT,".",2)=24 ; assume entire day
I 'SILENT W !,"Thinking..."
S ^ABSP(9002313.99,1,$T(+0))=BEGINDT_U_ENDDT_U_$$NOW
D CLEAN61
D BUILD61
S $P(^ABSP(9002313.99,1,$T(+0)),U,4)=$$NOW
D UNLOCK61
I 'SILENT W !,"Done",!
Q:$Q 1 Q
AUTO(SILENT) ; EP - entry action to the claims report menu
; automatically update for a few days prior to the last update
; up through the end of today
I '$D(SILENT) D S SILENT=1
. W !,"...updating the Report Master file, please stand by...",!
L +^ABSP(9002313.99,1,$T(+0)):+0 Q:'$T ; could be timing probs; just go on
N PREV S PREV=$P($G(^ABSP(9002313.99,1,$T(+0))),U,3) ;
I 'PREV D
. S PREV=$$TADD^ABSPOSUD($$NOW,-31)\1 ; first time? back 1 month
. Q:SILENT
. W !,"Report Master file is being prepared for its first use.",!
. W "The past month's transactions will be loaded.",!
. W "If you need to do older reports, use the menu option to ",!
. W "update the Report Master for a specific date range.",!
I PREV,PREV\1=DT S PREV=DT ; second time thru today? just do today
E S PREV=$$TADD^ABSPOSUD(PREV,-1) ; else reach back 1 day more
N THRU S THRU=DT+.24
I 'SILENT D
. W !,"Updating the Report Master file for "
. N Y S Y=PREV X ^DD("DD") W Y
. S Y=THRU X ^DD("DD") W " thru ",Y,!
;W "Press ENTER at any time to stop the update.",!
N ATTIME S ATTIME=$$NOW
I '$$UPDATE61(PREV,THRU,SILENT) G AUTO9
AUTO9 L -^ABSP(9002313.99,1,$T(+0))
Q
PREPARE ; not used?
D WHY
P1 Q:$$UPDYN'=1
N N S N=$$UPDWHEN I N="" G P1
W !,"Updating..."
S N=$$TADD^ABSPOSUD(DT,-N)
Q:$$UPDATE61(N,DT)
W !,"Couldn't update the Report Master file",!
W "You may still try to run some reports, however.",!
Q
PURPOSE W "The Report Master file is the mechanism which",!
W "links the Prescription and POS Transaction files together",!
W "for efficient sorting and Fileman reporting.",!
Q
WHY ;
W "The Report Master file may need to be updated with the latest",!
W "prescription Released Dates and POS Transaction Numbers",!
W "to ensure 100% accurate reporting.",!
Q
UPDYN() N PROMPT S PROMPT="Update the Report Master file now"
N DEF S DEF="YES"
N OPT S OPT=1
N X S X=$$YESNO^ABSPOSU3(PROMPT,DEF,OPT)
Q $S(X=0:0,X=1:1,1:"")
UPDWHEN() N PROMPT S PROMPT="Update the Report Master file going back how many days? "
N DEF S DEF=7
I DEF="" S DEF=1 ; yesterday and today
N OPT S OPT=1 ; optional response
N MIN S MIN=0 ; 0 would mean just today
N MAX S MAX=366
N X S X=$$NUMERIC^ABSPOSU2(PROMPT,DEF,OPT,MIN,MAX,0)
I X'?1N.N Q ""
Q X
LASTRUN N REC S REC=$G(^ABSP(9002313.99,1,$T(+0)))
I REC="" W "This is the first time the Report Master file has ever been updated.",! Q
W "The last time the Report Master file was updated was "
N Y S Y=$P(REC,U,4) S:'Y Y=$P(REC,U,3) X ^DD("DD") W Y,!
W "The update covered "
S Y=$P(REC,U) X ^DD("DD") W Y
S Y=$P(REC,U,2)
I Y'=$P(REC,U) W " thru " X ^DD("DD") W Y
W !
Q
CLEAN61 ;EP - Clean up 9002313.61 for BEGINDT - ENDDT
; Delete all entries for which the release date has changed.
; Could be that the release date changed on something.
;
;IHS/SD/lwj 2/5/04 lost pointers for RXR/RXI (patch 9)
; adjusted logic of setting WHEN1 to avoid <SBSCR> error
; Within loop, E S WHEN1 remarked out, nxt line added
;
N WHEN,WHEN1 S WHEN=BEGINDT
S WHEN1=0 ;IHS/SD/lwj 2/5/04 patch 9
F D S WHEN=$O(^ABSPECX("RPT","B",WHEN)) Q:'WHEN Q:WHEN>ENDDT
. N IEN S IEN=0 F S IEN=$O(^ABSPECX("RPT","B",WHEN,IEN)) Q:'IEN D
. . ;N X S X=^ABSPECX("RPT",IEN,0) ; IHS/OIT/SCR 010510 START avoid undefined error patch 36
. . N X S X=$G(^ABSPECX("RPT",IEN,0))
. . I X="" W !,"CORRUPTED X-REF FOUND!",!,"RE-INDEX ABSP REPORT MASTER" Q ;IHS/OIT/SCR 010510 END avoid undefined error patch 36
. . S RXI=$P(X,U,4),RXR=$P(X,U,5)
. . I RXR S WHEN1=$P($G(^PSRX(RXI,1,RXR,0)),U,18)
. . ;E S WHEN1=$P($G(^PSRX(RXI,2)),U,13) ;IHS/SD/lwj 2/5/04 ptch 9
. . E S:RXI'="" WHEN1=$P($G(^PSRX(RXI,2)),U,13) ;IHS/SD/lwj 2/5/04
. . I WHEN'=(WHEN1\1) D DELETE(IEN)
Q
BUILD61 ; Build file 9002313.61 for BEGINDT - ENDDT
N IEN S IEN=0
N WHEN,RXI,RXR S WHEN=BEGINDT
F D S WHEN=$O(^PSRX("AL",WHEN)) Q:'WHEN Q:WHEN>ENDDT
. S RXI="" F S RXI=$O(^PSRX("AL",WHEN,RXI)) Q:RXI="" D
. . S RXR="" F S RXR=$O(^PSRX("AL",WHEN,RXI,RXR)) Q:RXR="" D
. . . D ONE
Q
LOCK61() L +^ABSPECX("RPT"):0 Q $T
UNLOCK61 L -^ABSPECX("RPT") Q
DELETE(IEN) ;
N FDA,MSG
S FDA(9002313.61,IEN_",",.01)=""
D5 D FILE^DIE(,"FDA","MSG")
I $D(MSG) D LOG^ABSPOSL2("D5^ABSPOSM1",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
Q:'$D(MSG) ; success
D ZWRITE^ABSPOS("FDA","MSG")
G D5:$$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"DELETE",$T(+0))
Q
FIND() ; look for existing RXI,RXR entry in 9002313.61
N IEN,FOUND S (IEN,FOUND)=0
F S IEN=$O(^ABSPECX("RPT","C",RXI,IEN)) Q:'IEN D Q:FOUND
. ;N X S X=^ABSPECX("RPT",IEN,0) ;IHS/OIT/SCR 011510 START avoid undefined error patch 36
. N X S X=$G(^ABSPECX("RPT",IEN,0))
. I X="" W !,"CORRUPTED X-REF FOUND!",!,"RE-INDEX ABSP REPORT MASTER" Q ;IHS/OIT/SCR 011510 END avoid undefined error patch 36
. I $P(X,U,5)=RXR S FOUND=IEN
Q FOUND
ONE ; RXI, RXR released at time WHEN
N FDA,MSG,FN,IENS,IEN57,X
S IENS=$$FIND
I '$$FIND S IENS="+1"
S IENS=IENS_","
S FN=9002313.61
S FDA(FN,IENS,.01)=WHEN\1 ; truncate - date only.
S (IEN57,FDA(FN,IENS,.03))=$$LAST57^ABSPOSBB(RXI,RXR)
; added "I IEN57" to next line
I IEN57 S FDA(FN,IENS,.02)=$P($P($G(^ABSPTL(IEN57,0)),U,8),".") ;ABSP*1.0T7*1
S FDA(FN,IENS,.04)=RXI
S FDA(FN,IENS,.05)=RXR
N RWR,X
I IEN57 S RWR=$$GET1^DIQ(9002313.57,IEN57_",","RESULT WITH REVERSAL")
E S RWR=""
;
; Note! Computed fields rely on these code values.
; Also, AMOUNT OTHER takes in all the X<0 cases
;
I RWR?1"E ".E D
. S X=RWR
. I X="E PAYABLE" S X=4
. E I X="E CAPTURED" S X=3
. E I X="E DUPLICATE" S X=2
. E I X="E REJECTED" S X=1
. E I X="E REVERSAL ACCEPTED" S X=11
. E I X="E REVERSAL REJECTED" S X=12
. E S X=0
E I RWR="PAPER" S X=9
E I RWR="PAPER REVERSAL" S X=19
E S X=15
S FDA(FN,IENS,.06)=X
;
; If the claim has any message text, store it
; IHS/OIT/SCR 05/04/09 patch 31 : don't store information if it starts and ends with '&'
; e.g. a value of '&ECL;RC:300;&' is a string of multiple Return Codes separated by ';' but
; it looks like garbage on reports and we don't want to see it there. Only Caremark formats
; are using these strings at the moment and no parsing is attempted by this patch
N MSGTEXT
I RWR?1"E ".E D
. S X=$$MESSAGE^ABSPOSM(IEN57,1)
. ;I ($E(X,1,1)="&")&&($E(X,$L(X),$L(X))="&") Q ;IHS/OIT/SCR 05/12/09
. I ($E(X,1,1)="&")&($E(X,$L(X),$L(X))="&") S MSGTEXT(1)="**Screened Msg" Q ;IHS/OIT/SCR 05/15/09
. ;I X["SPH:mmc3" Q ;IHS/OIT/SCR 05/12/09
. I X["SPH:mmc3" S MSGTEXT(1)="**Screened Msg" Q ;IHS/OIT/SCR 05/12/09
. I X]"" S MSGTEXT(1)=X
. S MSGTEXT(1)=X
. S X=$$MESSAGE^ABSPOSM(IEN57,2)
. I ($E(X,1,1)=";") S X=$E(X,2,$L(X)) ;IHS/OIT/SCR patch 32 06/15/09 - remove leading ";"
. I ($E(X,$L(X),$L(X))=";") S X=$E(X,1,$L(X)-1) ;IHS/OIT/SCR patch 32 06/15/09 - remove trailing ";"
. I ($E(X,1,1)="&")&($E(X,$L(X),$L(X))="&") S MSGTEXT(2)="**Screened Msg" Q ;IHS/OIT/SCR 05/15/09
. I X["SPH:mmc3" S MSGTEXT(2)="**Screened Msg" Q ;IHS/OIT/SCR 05/15/09
. I X]"" S MSGTEXT(2)=X
I $D(MSGTEXT) S FDA(FN,IENS,1300)="MSGTEXT"
E S FDA(FN,IENS,1300)=""
;
; If it's a rejected claim, build the rejection text
;
N REJTEXT
I RWR="E REJECTED"!(RWR="E REVERSAL REJECTED") D
. N RESP,POS D RESPPOS^ABSPOSM(IEN57) ; set RESP,POS pointers
. D REJTEXT^ABSPOS03(RESP,POS,.REJTEXT)
. ; word processing text goes into FDA(FILE,IENS,FIELD,n)=text
. S FDA(FN,IENS,1800)=$S($D(REJTEXT):"REJTEXT",1:"")
E S FDA(FN,IENS,1800)=""
ONE5 I IENS["+" D
. D UPDATE^DIE(,"FDA",,"MSG")
. I $D(MSG) D LOG^ABSPOSL2("ONE5+2^ABSPOSK1",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
E D
. D FILE^DIE(,"FDA","MSG")
. I $D(MSG) D LOG^ABSPOSL2("ONE5+5^ABSPOSK1",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
Q:'$D(MSG) ; success
D ZWRITE^ABSPOS("IENS","FDA","MSG")
G ONE5:$$IMPOSS^ABSPOSUE("FM","TRI",$S(IENS["+":"UPDATE",1:"FILE")_"^DIE failed",,"ONE5",$T(+0))
Q
NOW() N %,%H,%I,X D NOW^%DTC Q %
Q
ABSPOSM1 ; IHS/FCS/DRS - build Report Master data ; [ 09/12/2002 10:12 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**3,9,31,32,36,48**;JUN 21, 2001;Build 38
+2 QUIT
+3 ;
+4 ; File 9002313.61 - ABSP REPORT MASTER
+5 ; Purpose: make it easy to use Fileman to get data,
+6 ; by storing pointers to various places, indexed by Release Date
+7 ;
+8 ;----------------------------------------------------------
+9 ; IHS/SD/lwj 2/5/04 patch 9 logic added to CLEAN61 to
+10 ; avoid missing RXI and RXR pointers. (?? not sure why
+11 ; they are missing - and they are only missing at Santa Fe.
+12 ; Without the RX to reference, it's almost impossible to
+13 ; track down.)
+14 ;
+15 ;----------------------------------------------------------
+16 ;
UPDATE61(BEGINDT,ENDDT,SILENT) ; EP - update the .61 file.
+1 ; If called with $$, returns 1 success, 0 failure
+2 IF '$DATA(SILENT)
SET SILENT=0
+3 IF 'SILENT
WRITE !!
DO LASTRUN
+4 IF '$$LOCK61
Begin DoDot:1
+5 IF 'SILENT
WRITE !,"Someone else is already using this program.",!
End DoDot:1
IF $QUIT
QUIT 0
QUIT
+6 IF '$DATA(BEGINDT)
Begin DoDot:1
+7 NEW X
+8 WRITE !,"Choose the date range of prescription RELEASE DATE",!
+9 WRITE "to include in this report.",!
+10 SET X=$$DTR^ABSPOSU1("Starting at date@time: ","Thru date@time: ",,,"T")
+11 IF 'X
QUIT
+12 SET BEGINDT=$PIECE(X,U)
SET ENDDT=$PIECE(X,U,2)
End DoDot:1
IF '$DATA(BEGINDT)
IF $QUIT
QUIT 0
QUIT
+13 IF '$DATA(ENDDT)
SET ENDDT=BEGINDT
+14 ; assume entire day
IF $PIECE(ENDDT,".",2)=""
SET $PIECE(ENDDT,".",2)=24
+15 IF 'SILENT
WRITE !,"Thinking..."
+16 SET ^ABSP(9002313.99,1,$TEXT(+0))=BEGINDT_U_ENDDT_U_$$NOW
+17 DO CLEAN61
+18 DO BUILD61
+19 SET $PIECE(^ABSP(9002313.99,1,$TEXT(+0)),U,4)=$$NOW
+20 DO UNLOCK61
+21 IF 'SILENT
WRITE !,"Done",!
+22 IF $QUIT
QUIT 1
QUIT
AUTO(SILENT) ; EP - entry action to the claims report menu
+1 ; automatically update for a few days prior to the last update
+2 ; up through the end of today
+3 IF '$DATA(SILENT)
Begin DoDot:1
+4 WRITE !,"...updating the Report Master file, please stand by...",!
End DoDot:1
SET SILENT=1
+5 ; could be timing probs; just go on
LOCK +^ABSP(9002313.99,1,$TEXT(+0)):+0
IF '$TEST
QUIT
+6 ;
NEW PREV
SET PREV=$PIECE($GET(^ABSP(9002313.99,1,$TEXT(+0))),U,3)
+7 IF 'PREV
Begin DoDot:1
+8 ; first time? back 1 month
SET PREV=$$TADD^ABSPOSUD($$NOW,-31)\1
+9 IF SILENT
QUIT
+10 WRITE !,"Report Master file is being prepared for its first use.",!
+11 WRITE "The past month's transactions will be loaded.",!
+12 WRITE "If you need to do older reports, use the menu option to ",!
+13 WRITE "update the Report Master for a specific date range.",!
End DoDot:1
+14 ; second time thru today? just do today
IF PREV
IF PREV\1=DT
SET PREV=DT
+15 ; else reach back 1 day more
IF '$TEST
SET PREV=$$TADD^ABSPOSUD(PREV,-1)
+16 NEW THRU
SET THRU=DT+.24
+17 IF 'SILENT
Begin DoDot:1
+18 WRITE !,"Updating the Report Master file for "
+19 NEW Y
SET Y=PREV
XECUTE ^DD("DD")
WRITE Y
+20 SET Y=THRU
XECUTE ^DD("DD")
WRITE " thru ",Y,!
End DoDot:1
+21 ;W "Press ENTER at any time to stop the update.",!
+22 NEW ATTIME
SET ATTIME=$$NOW
+23 IF '$$UPDATE61(PREV,THRU,SILENT)
GOTO AUTO9
AUTO9 LOCK -^ABSP(9002313.99,1,$TEXT(+0))
+1 QUIT
PREPARE ; not used?
+1 DO WHY
P1 IF $$UPDYN'=1
QUIT
+1 NEW N
SET N=$$UPDWHEN
IF N=""
GOTO P1
+2 WRITE !,"Updating..."
+3 SET N=$$TADD^ABSPOSUD(DT,-N)
+4 IF $$UPDATE61(N,DT)
QUIT
+5 WRITE !,"Couldn't update the Report Master file",!
+6 WRITE "You may still try to run some reports, however.",!
+7 QUIT
PURPOSE WRITE "The Report Master file is the mechanism which",!
+1 WRITE "links the Prescription and POS Transaction files together",!
+2 WRITE "for efficient sorting and Fileman reporting.",!
+3 QUIT
WHY ;
+1 WRITE "The Report Master file may need to be updated with the latest",!
+2 WRITE "prescription Released Dates and POS Transaction Numbers",!
+3 WRITE "to ensure 100% accurate reporting.",!
+4 QUIT
UPDYN() NEW PROMPT
SET PROMPT="Update the Report Master file now"
+1 NEW DEF
SET DEF="YES"
+2 NEW OPT
SET OPT=1
+3 NEW X
SET X=$$YESNO^ABSPOSU3(PROMPT,DEF,OPT)
+4 QUIT $SELECT(X=0:0,X=1:1,1:"")
UPDWHEN() NEW PROMPT
SET PROMPT="Update the Report Master file going back how many days? "
+1 NEW DEF
SET DEF=7
+2 ; yesterday and today
IF DEF=""
SET DEF=1
+3 ; optional response
NEW OPT
SET OPT=1
+4 ; 0 would mean just today
NEW MIN
SET MIN=0
+5 NEW MAX
SET MAX=366
+6 NEW X
SET X=$$NUMERIC^ABSPOSU2(PROMPT,DEF,OPT,MIN,MAX,0)
+7 IF X'?1N.N
QUIT ""
+8 QUIT X
LASTRUN NEW REC
SET REC=$GET(^ABSP(9002313.99,1,$TEXT(+0)))
+1 IF REC=""
WRITE "This is the first time the Report Master file has ever been updated.",!
QUIT
+2 WRITE "The last time the Report Master file was updated was "
+3 NEW Y
SET Y=$PIECE(REC,U,4)
IF 'Y
SET Y=$PIECE(REC,U,3)
XECUTE ^DD("DD")
WRITE Y,!
+4 WRITE "The update covered "
+5 SET Y=$PIECE(REC,U)
XECUTE ^DD("DD")
WRITE Y
+6 SET Y=$PIECE(REC,U,2)
+7 IF Y'=$PIECE(REC,U)
WRITE " thru "
XECUTE ^DD("DD")
WRITE Y
+8 WRITE !
+9 QUIT
CLEAN61 ;EP - Clean up 9002313.61 for BEGINDT - ENDDT
+1 ; Delete all entries for which the release date has changed.
+2 ; Could be that the release date changed on something.
+3 ;
+4 ;IHS/SD/lwj 2/5/04 lost pointers for RXR/RXI (patch 9)
+5 ; adjusted logic of setting WHEN1 to avoid <SBSCR> error
+6 ; Within loop, E S WHEN1 remarked out, nxt line added
+7 ;
+8 NEW WHEN,WHEN1
SET WHEN=BEGINDT
+9 ;IHS/SD/lwj 2/5/04 patch 9
SET WHEN1=0
+10 FOR
Begin DoDot:1
+11 NEW IEN
SET IEN=0
FOR
SET IEN=$ORDER(^ABSPECX("RPT","B",WHEN,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+12 ;N X S X=^ABSPECX("RPT",IEN,0) ; IHS/OIT/SCR 010510 START avoid undefined error patch 36
+13 NEW X
SET X=$GET(^ABSPECX("RPT",IEN,0))
+14 ;IHS/OIT/SCR 010510 END avoid undefined error patch 36
IF X=""
WRITE !,"CORRUPTED X-REF FOUND!",!,"RE-INDEX ABSP REPORT MASTER"
QUIT
+15 SET RXI=$PIECE(X,U,4)
SET RXR=$PIECE(X,U,5)
+16 IF RXR
SET WHEN1=$PIECE($GET(^PSRX(RXI,1,RXR,0)),U,18)
+17 ;E S WHEN1=$P($G(^PSRX(RXI,2)),U,13) ;IHS/SD/lwj 2/5/04 ptch 9
+18 ;IHS/SD/lwj 2/5/04
IF '$TEST
IF RXI'=""
SET WHEN1=$PIECE($GET(^PSRX(RXI,2)),U,13)
+19 IF WHEN'=(WHEN1\1)
DO DELETE(IEN)
End DoDot:2
End DoDot:1
SET WHEN=$ORDER(^ABSPECX("RPT","B",WHEN))
IF 'WHEN
QUIT
IF WHEN>ENDDT
QUIT
+20 QUIT
BUILD61 ; Build file 9002313.61 for BEGINDT - ENDDT
+1 NEW IEN
SET IEN=0
+2 NEW WHEN,RXI,RXR
SET WHEN=BEGINDT
+3 FOR
Begin DoDot:1
+4 SET RXI=""
FOR
SET RXI=$ORDER(^PSRX("AL",WHEN,RXI))
IF RXI=""
QUIT
Begin DoDot:2
+5 SET RXR=""
FOR
SET RXR=$ORDER(^PSRX("AL",WHEN,RXI,RXR))
IF RXR=""
QUIT
Begin DoDot:3
+6 DO ONE
End DoDot:3
End DoDot:2
End DoDot:1
SET WHEN=$ORDER(^PSRX("AL",WHEN))
IF 'WHEN
QUIT
IF WHEN>ENDDT
QUIT
+7 QUIT
LOCK61() LOCK +^ABSPECX("RPT"):0
QUIT $TEST
UNLOCK61 LOCK -^ABSPECX("RPT")
QUIT
DELETE(IEN) ;
+1 NEW FDA,MSG
+2 SET FDA(9002313.61,IEN_",",.01)=""
D5 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("D5^ABSPOSM1",.MSG)
+2 ; success
IF '$DATA(MSG)
QUIT
+3 DO ZWRITE^ABSPOS("FDA","MSG")
+4 IF $$IMPOSS^ABSPOSUE("FM","TRI","FILE^DIE failed",,"DELETE",$TEXT(+0))
GOTO D5
+5 QUIT
FIND() ; look for existing RXI,RXR entry in 9002313.61
+1 NEW IEN,FOUND
SET (IEN,FOUND)=0
+2 FOR
SET IEN=$ORDER(^ABSPECX("RPT","C",RXI,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+3 ;N X S X=^ABSPECX("RPT",IEN,0) ;IHS/OIT/SCR 011510 START avoid undefined error patch 36
+4 NEW X
SET X=$GET(^ABSPECX("RPT",IEN,0))
+5 ;IHS/OIT/SCR 011510 END avoid undefined error patch 36
IF X=""
WRITE !,"CORRUPTED X-REF FOUND!",!,"RE-INDEX ABSP REPORT MASTER"
QUIT
+6 IF $PIECE(X,U,5)=RXR
SET FOUND=IEN
End DoDot:1
IF FOUND
QUIT
+7 QUIT FOUND
ONE ; RXI, RXR released at time WHEN
+1 NEW FDA,MSG,FN,IENS,IEN57,X
+2 SET IENS=$$FIND
+3 IF '$$FIND
SET IENS="+1"
+4 SET IENS=IENS_","
+5 SET FN=9002313.61
+6 ; truncate - date only.
SET FDA(FN,IENS,.01)=WHEN\1
+7 SET (IEN57,FDA(FN,IENS,.03))=$$LAST57^ABSPOSBB(RXI,RXR)
+8 ; added "I IEN57" to next line
+9 ;ABSP*1.0T7*1
IF IEN57
SET FDA(FN,IENS,.02)=$PIECE($PIECE($GET(^ABSPTL(IEN57,0)),U,8),".")
+10 SET FDA(FN,IENS,.04)=RXI
+11 SET FDA(FN,IENS,.05)=RXR
+12 NEW RWR,X
+13 IF IEN57
SET RWR=$$GET1^DIQ(9002313.57,IEN57_",","RESULT WITH REVERSAL")
+14 IF '$TEST
SET RWR=""
+15 ;
+16 ; Note! Computed fields rely on these code values.
+17 ; Also, AMOUNT OTHER takes in all the X<0 cases
+18 ;
+19 IF RWR?1"E ".E
Begin DoDot:1
+20 SET X=RWR
+21 IF X="E PAYABLE"
SET X=4
+22 IF '$TEST
IF X="E CAPTURED"
SET X=3
+23 IF '$TEST
IF X="E DUPLICATE"
SET X=2
+24 IF '$TEST
IF X="E REJECTED"
SET X=1
+25 IF '$TEST
IF X="E REVERSAL ACCEPTED"
SET X=11
+26 IF '$TEST
IF X="E REVERSAL REJECTED"
SET X=12
+27 IF '$TEST
SET X=0
End DoDot:1
+28 IF '$TEST
IF RWR="PAPER"
SET X=9
+29 IF '$TEST
IF RWR="PAPER REVERSAL"
SET X=19
+30 IF '$TEST
SET X=15
+31 SET FDA(FN,IENS,.06)=X
+32 ;
+33 ; If the claim has any message text, store it
+34 ; IHS/OIT/SCR 05/04/09 patch 31 : don't store information if it starts and ends with '&'
+35 ; e.g. a value of '&ECL;RC:300;&' is a string of multiple Return Codes separated by ';' but
+36 ; it looks like garbage on reports and we don't want to see it there. Only Caremark formats
+37 ; are using these strings at the moment and no parsing is attempted by this patch
+38 NEW MSGTEXT
+39 IF RWR?1"E ".E
Begin DoDot:1
+40 SET X=$$MESSAGE^ABSPOSM(IEN57,1)
+41 ;I ($E(X,1,1)="&")&&($E(X,$L(X),$L(X))="&") Q ;IHS/OIT/SCR 05/12/09
+42 ;IHS/OIT/SCR 05/15/09
IF ($EXTRACT(X,1,1)="&")&($EXTRACT(X,$LENGTH(X),$LENGTH(X))="&")
SET MSGTEXT(1)="**Screened Msg"
QUIT
+43 ;I X["SPH:mmc3" Q ;IHS/OIT/SCR 05/12/09
+44 ;IHS/OIT/SCR 05/12/09
IF X["SPH:mmc3"
SET MSGTEXT(1)="**Screened Msg"
QUIT
+45 IF X]""
SET MSGTEXT(1)=X
+46 SET MSGTEXT(1)=X
+47 SET X=$$MESSAGE^ABSPOSM(IEN57,2)
+48 ;IHS/OIT/SCR patch 32 06/15/09 - remove leading ";"
IF ($EXTRACT(X,1,1)=";")
SET X=$EXTRACT(X,2,$LENGTH(X))
+49 ;IHS/OIT/SCR patch 32 06/15/09 - remove trailing ";"
IF ($EXTRACT(X,$LENGTH(X),$LENGTH(X))=";")
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+50 ;IHS/OIT/SCR 05/15/09
IF ($EXTRACT(X,1,1)="&")&($EXTRACT(X,$LENGTH(X),$LENGTH(X))="&")
SET MSGTEXT(2)="**Screened Msg"
QUIT
+51 ;IHS/OIT/SCR 05/15/09
IF X["SPH:mmc3"
SET MSGTEXT(2)="**Screened Msg"
QUIT
+52 IF X]""
SET MSGTEXT(2)=X
End DoDot:1
+53 IF $DATA(MSGTEXT)
SET FDA(FN,IENS,1300)="MSGTEXT"
+54 IF '$TEST
SET FDA(FN,IENS,1300)=""
+55 ;
+56 ; If it's a rejected claim, build the rejection text
+57 ;
+58 NEW REJTEXT
+59 IF RWR="E REJECTED"!(RWR="E REVERSAL REJECTED")
Begin DoDot:1
+60 ; set RESP,POS pointers
NEW RESP,POS
DO RESPPOS^ABSPOSM(IEN57)
+61 DO REJTEXT^ABSPOS03(RESP,POS,.REJTEXT)
+62 ; word processing text goes into FDA(FILE,IENS,FIELD,n)=text
+63 SET FDA(FN,IENS,1800)=$SELECT($DATA(REJTEXT):"REJTEXT",1:"")
End DoDot:1
+64 IF '$TEST
SET FDA(FN,IENS,1800)=""
ONE5 IF IENS["+"
Begin DoDot:1
+1 DO UPDATE^DIE(,"FDA",,"MSG")
+2 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("ONE5+2^ABSPOSK1",.MSG)
End DoDot:1
+3 IF '$TEST
Begin DoDot:1
+4 DO FILE^DIE(,"FDA","MSG")
+5 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("ONE5+5^ABSPOSK1",.MSG)
End DoDot:1
+6 ; success
IF '$DATA(MSG)
QUIT
+7 DO ZWRITE^ABSPOS("IENS","FDA","MSG")
+8 IF $$IMPOSS^ABSPOSUE("FM","TRI",$SELECT(IENS["+":"UPDATE",1:"FILE")_"^DIE failed",,"ONE5",$TEXT(+0))
GOTO ONE5
+9 QUIT
NOW() NEW %,%H,%I,X
DO NOW^%DTC
QUIT %
+1 QUIT
