ABSPOSQL ; IHS/FCS/DRS - Process responses ; [ 10/07/2002 8:20 AM ]
;;1.0;PHARMACY POINT OF SALE;**3,29,31,32,48**;JUN 21, 2001;Build 38
;
;-----------------------------------------------------
;IHS/SD/lwj 10/07/02 NCPDP 5.1 changes
; The reversal claim now has a transaction code of "B2" instead of
; 11. Needed to adjust the ISREVERS routine to account for the
; difference. Also adjusted the RESP1 routine to check the
; additional message field (526) since not all processors will use
; the 504 message field in 5.1.
;
;-----------------------------------------------------
Q
;
; Subroutines from ABSPOSQ4 - the main line of processing is in here.
; The utility subroutines remain in ABSPOSQ4.
;
; RESPONSE(DIALOUT)
; Processes all response packets for this DIALOUT
; Creates 9002313.03 response record
; At this point, you are guaranteed to be the only job
; processing responses for this DIALOUT - you have a LOCK on
; that privilege, set up in ABSPOSQ4. But the old LOCK logic
; is retained in here, in case that ABSPOSQ4 restriction is
; ever removed.
; ONE(CLAIMIEN,RESPIEN)
; Process the 9002313.03 RESPIEN for the 9002313.02 CLAIMIEN
; Loops through all 9002313.59's represented in the CLAIMIEN
; ONE1(IEN59)
; Processing the 9002313.03 RESPIEN for this one IEN59
; It's just a tiny wrapper for RESP1 to save,set,restore logging
; RESP1
; The real work of response handling for one IEN59 is in here
;
RESPONSE(DIALOUT) ;EP - ABSPOSQ4
;
; Currently, the caller from ABSPOSQ4 will already have the
; lock on ^TMP("ABSPOSQ4",DIALOUT)
; This routine tries to get L +^ABSPECX("POS",DIALOUT,"R")
; and then L +^ABSPECX("POS",DIALOUT,"R",CLAIMIEN)
; All of this locking could be greatly simplified, it seems.
;
N CLAIMIEN,RESPIEN,RESPREC,CLAIMID,DIC,X,Y
S CLAIMIEN=""
F D Q:CLAIMIEN=""
. I '$$LLIST S CLAIMIEN="" Q ; Lock the whole list of responses
. ;D LOG^ABSPOSL("PRAscii1^"_$T(+0)_" 1. with CLAIMIEN="_CLAIMIEN)
. S CLAIMIEN=$O(^ABSPECX("POS",DIALOUT,"R",CLAIMIEN))
. ;D LOG^ABSPOSL("PRAscii1^"_$T(+0)_" 2. with CLAIMIEN="_CLAIMIEN)
. I CLAIMIEN="" D ULLIST Q
. ; lock the individual response and unlock the list (useless oper?)
. F Q:$$LRESP Q:'$$IMPOSS^ABSPOSUE("L","RI","Locking response for CLAIMIEN="_CLAIMIEN,,"RESPONSE",$T(+0))
. D ULLIST ; unlock the list
. ;
. ;Assemble RESPREC from scratch global
. S RESPREC=""
. N I F I=1:1:^ABSPECX("POS",DIALOUT,"R",CLAIMIEN,0) D
. . S RESPREC=RESPREC_^ABSPECX("POS",DIALOUT,"R",CLAIMIEN,I)
. S RESPREC=$P(RESPREC,$C(3))
. I RESPREC="" D Q ; null response? should be impossible,
. . ; but we saw it once at Parker.
. . D LOG^ABSPOSL($T(+0)_" - ??? Null response to CLAIMIEN "_CLAIMIEN)
. . D KILLRESP
. ;
. S CLAIMID=$P($G(^ABSPC(CLAIMIEN,0)),U,1)
. I CLAIMID="" D Q ; impossible?
. . D LOG^ABSPOSL($T(+0)_" - ??? CLAIMID is missing from "_CLAIMIEN)
. . D KILLRESP
. ;
. ;Create Claim Response Record (9002313.03)
. F D Q:RESPIEN'<1 Q:$$IMPOSS^ABSPOSUE("FM","TI","^DIC failed to create new ^ABSPR record for CLAIMID="_CLAIMID,,,$T(+0))
. . N X,DLAYGO,DIC,Y S X=""""_CLAIMID_""""
. . S DIC="^ABSPR(",DIC(0)="LXZ",DLAYGO=9002313.03 D ^DIC
. . S RESPIEN=+Y
. ;
. D LOG^ABSPOSL($T(+0)_" - Claim "_CLAIMIEN_" got Response "_RESPIEN)
. ;
. N STAMP S STAMP=$$NOWFM^ABSPOSU1()
. ;
. ;Set Date/Time Response Received field, set cross-reference
. S $P(^ABSPR(RESPIEN,0),U,2)=STAMP
. S ^ABSPR("AE",STAMP,RESPIEN)=""
. ;
. ;Set Transmitted On field, set cross-reference
. S $P(^ABSPC(CLAIMIEN,0),U,5)=STAMP
. S ^ABSPC("AE",STAMP,CLAIMIEN)=""
. ;
. ;Turn off transmit flag, reset cross-reference
. S $P(^ABSPC(CLAIMIEN,0),U,4)=0
. K ^ABSPC("AD",2,CLAIMIEN) ; 2 (POS) not 1 (old batch)
. S ^ABSPC("AD",0,CLAIMIEN)=""
. ;
. ;Parse and File Ascii Response record in Claim Response File
. D PARSE^ABSPECA4(RESPREC,RESPIEN)
. ;
. ; and the right place to process POS responses is here!!!!
. ;
. ; (there was some problem with this slot stacking mechanism?)
. ;N OLDSLOT S OLDSLOT=$$GETSLOT^ABSPOSL ; remember current slot
. D ONE(CLAIMIEN,RESPIEN)
. ;D SETSLOT^ABSPOSL(OLDSLOT) ; restore the old one
. ;
. D KILLRESP ; kill the scratch response
. ; Save a copy of the received packet, too
. N WP,I,ZERR F I=1:100:$L(RESPREC) S WP(I/100+1,0)=$E(RESPREC,I,I+99)
. D WP^DIE(9002313.03,RESPIEN_",",9999,"","WP","ZERR") ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
. I $D(ZERR) D LOG^ABSPOSL2("RESPONSE+72^ABSPOSQL",.ZERR) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
. D ULRESP ; unlock the response
. Q
Q
;IHS/SD/lwj 10/07/02 NCPDP 5.1 changes - for reversals we need
; to account for a transaction code of 11 for 3.2 claims and
; B2 for 5.1 claims. The next line was remarked out and
; replaced with the 6 lines following it.
;ISREVERS(X) Q $P(^ABSPC(X,100),U,3)=11 ; trans.code REVERSAL
ISREVERS(X) ; trans.code REVERSAL
;
N REVS
S REVS=0
S:($P(^ABSPC(X,100),U,3)=11)!($P(^ABSPC(X,100),U,3)="B2") REVS=1
Q REVS
;
;IHS/SD/lwj 10/07/02 end changes to ISREVERS
;
ONE(CLAIMIEN,RESPIEN) ;
; Both the 9002313.02 and 9002313.03 are correct and complete
; Now update all of the prescription records affected by them.
; Loop: for each prescription represented in the original claim:
N OLDSLOT S OLDSLOT=$$GETSLOT^ABSPOSL
N ISREVERS S ISREVERS=$$ISREVERS(CLAIMIEN)
N X S X="RESPONSE -"
I ISREVERS S X=X_" REVERSAL -"
S X=X_" Response #"_RESPIEN
S X=X_" for Claim #"_CLAIMIEN D LOG^ABSPOSL(X)
N INDEX S INDEX=$S(ISREVERS:"AER",1:"AE")
N IEN59 S IEN59=0
F S IEN59=$O(^ABSPT(INDEX,CLAIMIEN,IEN59)) Q:IEN59="" D
. D ONE1(IEN59)
Q
ONE1(ABSBRXI) ; ABSBRXI would more properly be called IEN59
D SETSLOT^ABSPOSL(OLDSLOT)
D LOG^ABSPOSL("RESPONSE - for ^ABSPT("_ABSBRXI_")")
D RESP1
D SETSLOT^ABSPOSL(OLDSLOT) ; because RESP1 changed it, probably
Q
;----------------------------------------------------------------------
;Process ASCII Claim Response Records:
;
; 1. Loop through ^ABSPECX("POS",DIALOUT,$J,"R",CLAIMIEN)
; transmission scratch global
; 2. Assemble ASCII Claim Response Records
; 3. Create new records in Claim Response File (9002313.03)
; 4. Parse ASCII Claim Response Records then file in
; Claim Response File (9002313.03)
;----------------------------------------------------------------------
;
LLIST() L +^ABSPECX("POS",DIALOUT,"R"):60 Q $T
ULLIST L -^ABSPECX("POS",DIALOUT,"R") Q
LRESP() L +^ABSPECX("POS",DIALOUT,"R",CLAIMIEN):60 Q $T
ULRESP L -^ABSPECX("POS",DIALOUT,"R",CLAIMIEN) Q
KILLRESP K ^ABSPECX("POS",DIALOUT,"R",CLAIMIEN) Q
;
RESP1 ; called from ONE1
; ABSBRXI would more properly be called IEN59
N ERROR
S ERROR=0 ;IHS/OIT/SCR 050409
D SETSLOT^ABSPOSL(ABSBRXI) ; point to slot for logging
N REVERSAL S REVERSAL=$G(^ABSPT(ABSBRXI,4))>0
D ; store pointer to response
. N DIE,DA,DR S DIE=9002313.59,DA=ABSBRXI
. S DR=$S(REVERSAL:402,1:4)_"////"_RESPIEN
. D ^DIE
D SETSTAT^ABSPOSU(90) ; "Processing response"
;D LOG^ABSPOSL("RESPONSE - Status (Header) = "_$P($G(^ABSPR(RESPIEN,500)),U)
N POSITION S POSITION=$P(^ABSPT(ABSBRXI,0),U,9)
I REVERSAL S POSITION=1 ; but reversals have only 1 transaction
D LOG^ABSPOSL("RESPONSE - #"_RESPIEN_", POSITION="_POSITION)
;IHS/OIT/SCR 2/13/09 patch 29 modify next line to avoid undefined error is no such node exists
;I '$D(^ABSPR(RESPIEN,1000,POSITION,500)) S ERROR=1 G RESPBAD
;IHS/OIT/SCR 05/12/09 start changes to avoid continued undefined problems patch 31
I $G(POSITION)="" D
.S ERROR=1
.D RESPBAD
.Q
Q:ERROR
I $G(^ABSPR(RESPIEN,1000,POSITION,500))="" D
.S ERROR=1
.D RESPBAD
.Q
Q:ERROR
;IHS/OIT/SCR 05/12/09 end changes to avoid continued undefined problems patch 31
N RESP S RESP=$P(^ABSPR(RESPIEN,1000,POSITION,500),U)
D INCSTAT^ABSPOSUD("R",$S(RESP="R":2,RESP="P":3,RESP="D":4,RESP="C":5,1:19))
D
. N X S X="RESPONSE - Position "_POSITION_" = "_RESP
. I RESP="P" S X=X_" $"_$$INSPAID1^ABSPOS03(RESPIEN,POSITION)
. D LOG^ABSPOSL(X)
;
;IHS/SD/lwj 10/07/02 NCPDP 5.1 changes - look at field 526
; (additional message) if nothing found in 504
N X S X=$G(^ABSPR(RESPIEN,1000,POSITION,504))
I X="" S X=$G(^ABSPR(RESPIEN,1000,POSITION,526)) ;IHS/SD/lwj 10/07/02
I X]"" D LOG^ABSPOSL("RESPONSE - MESSAGE - "_X)
;
I RESP="R" D ; rejected, give rejection reasons
.N J S J=0 F S J=$O(^ABSPR(RESPIEN,1000,POSITION,511,J)) Q:'J D
..N R S R=$P($G(^ABSPR(RESPIEN,1000,POSITION,511,J,0)),U)
..N X I R]"" D
...S X=$O(^ABSPF(9002313.93,"B",R,0))
...I X]"" S X=$P($G(^ABSPF(9002313.93,X,0)),U,2)
..E S X=""
..D LOG^ABSPOSL("REJECT - "_R_" - "_X)
;
N INSURER S INSURER=$P(^ABSPT(ABSBRXI,1),U,6)
I $G(INSURER)="" D RESPBAD Q ;IHS/OIT/SCR 061809 patch 32 - if no insurer,process as corrupted response
I $$REJSLEEP^ABSPOSQ4(RESPIEN,POSITION) D ; ins. asleep: want to retry
. D SETSTAT^ABSPOSU(31)
. N X S X=$$INCSLEEP^ABSPOSQ4(INSURER)
. S $P(^ABSPT(IEN59,8),U)=X_U_U_INSURER
. D LOG^ABSPOSL($T(+0)_" - Insurer asleep; retry scheduled for "_X)
E D ; else: a normal kind of response, so we are done
. D CLRSLEEP^ABSPOSQ4(INSURER,1)
. D SETSTAT^ABSPOSU(99) ; "Done"
. I $G(^ABSPT(ABSBRXI,3)) D
. . D SETRESU^ABSPOSU(0,"Cancellation tried too late; claim sent.")
. E D
. . D SETRESU^ABSPOSU(0) ; indicates a complete response was received
; status reports should refer to the ^ABSPR entry
D RELSLOT^ABSPOSL
Q
RESPBAD ; corrupted response escape from RESP1 ; reached by a GOTO
N MSG S MSG="Corrupted response `"_RESPIEN
D SETSTAT^ABSPOSU(99) ; "Done"
D SETRESU^ABSPOSU(6500+$G(ERROR),MSG)
D LOG^ABSPOSL(MSG)
D DONE^ABSPOSL ; close up the logging slot
Q
ABSPOSQL ; IHS/FCS/DRS - Process responses ; [ 10/07/2002 8:20 AM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**3,29,31,32,48**;JUN 21, 2001;Build 38
+2 ;
+3 ;-----------------------------------------------------
+4 ;IHS/SD/lwj 10/07/02 NCPDP 5.1 changes
+5 ; The reversal claim now has a transaction code of "B2" instead of
+6 ; 11. Needed to adjust the ISREVERS routine to account for the
+7 ; difference. Also adjusted the RESP1 routine to check the
+8 ; additional message field (526) since not all processors will use
+9 ; the 504 message field in 5.1.
+10 ;
+11 ;-----------------------------------------------------
+12 QUIT
+13 ;
+14 ; Subroutines from ABSPOSQ4 - the main line of processing is in here.
+15 ; The utility subroutines remain in ABSPOSQ4.
+16 ;
+17 ; RESPONSE(DIALOUT)
+18 ; Processes all response packets for this DIALOUT
+19 ; Creates 9002313.03 response record
+20 ; At this point, you are guaranteed to be the only job
+21 ; processing responses for this DIALOUT - you have a LOCK on
+22 ; that privilege, set up in ABSPOSQ4. But the old LOCK logic
+23 ; is retained in here, in case that ABSPOSQ4 restriction is
+24 ; ever removed.
+25 ; ONE(CLAIMIEN,RESPIEN)
+26 ; Process the 9002313.03 RESPIEN for the 9002313.02 CLAIMIEN
+27 ; Loops through all 9002313.59's represented in the CLAIMIEN
+28 ; ONE1(IEN59)
+29 ; Processing the 9002313.03 RESPIEN for this one IEN59
+30 ; It's just a tiny wrapper for RESP1 to save,set,restore logging
+31 ; RESP1
+32 ; The real work of response handling for one IEN59 is in here
+33 ;
RESPONSE(DIALOUT) ;EP - ABSPOSQ4
+1 ;
+2 ; Currently, the caller from ABSPOSQ4 will already have the
+3 ; lock on ^TMP("ABSPOSQ4",DIALOUT)
+4 ; This routine tries to get L +^ABSPECX("POS",DIALOUT,"R")
+5 ; and then L +^ABSPECX("POS",DIALOUT,"R",CLAIMIEN)
+6 ; All of this locking could be greatly simplified, it seems.
+7 ;
+8 NEW CLAIMIEN,RESPIEN,RESPREC,CLAIMID,DIC,X,Y
+9 SET CLAIMIEN=""
+10 FOR
Begin DoDot:1
+11 ; Lock the whole list of responses
IF '$$LLIST
SET CLAIMIEN=""
QUIT
+12 ;D LOG^ABSPOSL("PRAscii1^"_$T(+0)_" 1. with CLAIMIEN="_CLAIMIEN)
+13 SET CLAIMIEN=$ORDER(^ABSPECX("POS",DIALOUT,"R",CLAIMIEN))
+14 ;D LOG^ABSPOSL("PRAscii1^"_$T(+0)_" 2. with CLAIMIEN="_CLAIMIEN)
+15 IF CLAIMIEN=""
DO ULLIST
QUIT
+16 ; lock the individual response and unlock the list (useless oper?)
+17 FOR
IF $$LRESP
QUIT
IF '$$IMPOSS^ABSPOSUE("L","RI","Locking response for CLAIMIEN="_CLAIMIEN,,"RESPONSE",$TEXT(+0))
QUIT
+18 ; unlock the list
DO ULLIST
+19 ;
+20 ;Assemble RESPREC from scratch global
+21 SET RESPREC=""
+22 NEW I
FOR I=1:1:^ABSPECX("POS",DIALOUT,"R",CLAIMIEN,0)
Begin DoDot:2
+23 SET RESPREC=RESPREC_^ABSPECX("POS",DIALOUT,"R",CLAIMIEN,I)
End DoDot:2
+24 SET RESPREC=$PIECE(RESPREC,$CHAR(3))
+25 ; null response? should be impossible,
IF RESPREC=""
Begin DoDot:2
+26 ; but we saw it once at Parker.
+27 DO LOG^ABSPOSL($TEXT(+0)_" - ??? Null response to CLAIMIEN "_CLAIMIEN)
+28 DO KILLRESP
End DoDot:2
QUIT
+29 ;
+30 SET CLAIMID=$PIECE($GET(^ABSPC(CLAIMIEN,0)),U,1)
+31 ; impossible?
IF CLAIMID=""
Begin DoDot:2
+32 DO LOG^ABSPOSL($TEXT(+0)_" - ??? CLAIMID is missing from "_CLAIMIEN)
+33 DO KILLRESP
End DoDot:2
QUIT
+34 ;
+35 ;Create Claim Response Record (9002313.03)
+36 FOR
Begin DoDot:2
+37 NEW X,DLAYGO,DIC,Y
SET X=""""_CLAIMID_""""
+38 SET DIC="^ABSPR("
SET DIC(0)="LXZ"
SET DLAYGO=9002313.03
DO ^DIC
+39 SET RESPIEN=+Y
End DoDot:2
IF RESPIEN'<1
QUIT
IF $$IMPOSS^ABSPOSUE("FM","TI","^DIC failed to create new ^ABSPR record for CLAIMID="_CLAIMID,,,$TEXT(+0))
QUIT
+40 ;
+41 DO LOG^ABSPOSL($TEXT(+0)_" - Claim "_CLAIMIEN_" got Response "_RESPIEN)
+42 ;
+43 NEW STAMP
SET STAMP=$$NOWFM^ABSPOSU1()
+44 ;
+45 ;Set Date/Time Response Received field, set cross-reference
+46 SET $PIECE(^ABSPR(RESPIEN,0),U,2)=STAMP
+47 SET ^ABSPR("AE",STAMP,RESPIEN)=""
+48 ;
+49 ;Set Transmitted On field, set cross-reference
+50 SET $PIECE(^ABSPC(CLAIMIEN,0),U,5)=STAMP
+51 SET ^ABSPC("AE",STAMP,CLAIMIEN)=""
+52 ;
+53 ;Turn off transmit flag, reset cross-reference
+54 SET $PIECE(^ABSPC(CLAIMIEN,0),U,4)=0
+55 ; 2 (POS) not 1 (old batch)
KILL ^ABSPC("AD",2,CLAIMIEN)
+56 SET ^ABSPC("AD",0,CLAIMIEN)=""
+57 ;
+58 ;Parse and File Ascii Response record in Claim Response File
+59 DO PARSE^ABSPECA4(RESPREC,RESPIEN)
+60 ;
+61 ; and the right place to process POS responses is here!!!!
+62 ;
+63 ; (there was some problem with this slot stacking mechanism?)
+64 ;N OLDSLOT S OLDSLOT=$$GETSLOT^ABSPOSL ; remember current slot
+65 DO ONE(CLAIMIEN,RESPIEN)
+66 ;D SETSLOT^ABSPOSL(OLDSLOT) ; restore the old one
+67 ;
+68 ; kill the scratch response
DO KILLRESP
+69 ; Save a copy of the received packet, too
+70 NEW WP,I,ZERR
FOR I=1:100:$LENGTH(RESPREC)
SET WP(I/100+1,0)=$EXTRACT(RESPREC,I,I+99)
+71 ; /IHS/OIT/RAM ; 12 JUN 17 ; UPDATE DBS CALL TO ALLOW FOR ERROR RETURN.
DO WP^DIE(9002313.03,RESPIEN_",",9999,"","WP","ZERR")
+72 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(ZERR)
DO LOG^ABSPOSL2("RESPONSE+72^ABSPOSQL",.ZERR)
+73 ; unlock the response
DO ULRESP
+74 QUIT
End DoDot:1
IF CLAIMIEN=""
QUIT
+75 QUIT
+76 ;IHS/SD/lwj 10/07/02 NCPDP 5.1 changes - for reversals we need
+77 ; to account for a transaction code of 11 for 3.2 claims and
+78 ; B2 for 5.1 claims. The next line was remarked out and
+79 ; replaced with the 6 lines following it.
+80 ;ISREVERS(X) Q $P(^ABSPC(X,100),U,3)=11 ; trans.code REVERSAL
ISREVERS(X) ; trans.code REVERSAL
+1 ;
+2 NEW REVS
+3 SET REVS=0
+4 IF ($PIECE(^ABSPC(X,100),U,3)=11)!($PIECE(^ABSPC(X,100),U,3)="B2")
SET REVS=1
+5 QUIT REVS
+6 ;
+7 ;IHS/SD/lwj 10/07/02 end changes to ISREVERS
+8 ;
ONE(CLAIMIEN,RESPIEN) ;
+1 ; Both the 9002313.02 and 9002313.03 are correct and complete
+2 ; Now update all of the prescription records affected by them.
+3 ; Loop: for each prescription represented in the original claim:
+4 NEW OLDSLOT
SET OLDSLOT=$$GETSLOT^ABSPOSL
+5 NEW ISREVERS
SET ISREVERS=$$ISREVERS(CLAIMIEN)
+6 NEW X
SET X="RESPONSE -"
+7 IF ISREVERS
SET X=X_" REVERSAL -"
+8 SET X=X_" Response #"_RESPIEN
+9 SET X=X_" for Claim #"_CLAIMIEN
DO LOG^ABSPOSL(X)
+10 NEW INDEX
SET INDEX=$SELECT(ISREVERS:"AER",1:"AE")
+11 NEW IEN59
SET IEN59=0
+12 FOR
SET IEN59=$ORDER(^ABSPT(INDEX,CLAIMIEN,IEN59))
IF IEN59=""
QUIT
Begin DoDot:1
+13 DO ONE1(IEN59)
End DoDot:1
+14 QUIT
ONE1(ABSBRXI) ; ABSBRXI would more properly be called IEN59
+1 DO SETSLOT^ABSPOSL(OLDSLOT)
+2 DO LOG^ABSPOSL("RESPONSE - for ^ABSPT("_ABSBRXI_")")
+3 DO RESP1
+4 ; because RESP1 changed it, probably
DO SETSLOT^ABSPOSL(OLDSLOT)
+5 QUIT
+6 ;----------------------------------------------------------------------
+7 ;Process ASCII Claim Response Records:
+8 ;
+9 ; 1. Loop through ^ABSPECX("POS",DIALOUT,$J,"R",CLAIMIEN)
+10 ; transmission scratch global
+11 ; 2. Assemble ASCII Claim Response Records
+12 ; 3. Create new records in Claim Response File (9002313.03)
+13 ; 4. Parse ASCII Claim Response Records then file in
+14 ; Claim Response File (9002313.03)
+15 ;----------------------------------------------------------------------
+16 ;
LLIST() LOCK +^ABSPECX("POS",DIALOUT,"R"):60
QUIT $TEST
ULLIST LOCK -^ABSPECX("POS",DIALOUT,"R")
QUIT
LRESP() LOCK +^ABSPECX("POS",DIALOUT,"R",CLAIMIEN):60
QUIT $TEST
ULRESP LOCK -^ABSPECX("POS",DIALOUT,"R",CLAIMIEN)
QUIT
KILLRESP KILL ^ABSPECX("POS",DIALOUT,"R",CLAIMIEN)
QUIT
+1 ;
RESP1 ; called from ONE1
+1 ; ABSBRXI would more properly be called IEN59
+2 NEW ERROR
+3 ;IHS/OIT/SCR 050409
SET ERROR=0
+4 ; point to slot for logging
DO SETSLOT^ABSPOSL(ABSBRXI)
+5 NEW REVERSAL
SET REVERSAL=$GET(^ABSPT(ABSBRXI,4))>0
+6 ; store pointer to response
Begin DoDot:1
+7 NEW DIE,DA,DR
SET DIE=9002313.59
SET DA=ABSBRXI
+8 SET DR=$SELECT(REVERSAL:402,1:4)_"////"_RESPIEN
+9 DO ^DIE
End DoDot:1
+10 ; "Processing response"
DO SETSTAT^ABSPOSU(90)
+11 ;D LOG^ABSPOSL("RESPONSE - Status (Header) = "_$P($G(^ABSPR(RESPIEN,500)),U)
+12 NEW POSITION
SET POSITION=$PIECE(^ABSPT(ABSBRXI,0),U,9)
+13 ; but reversals have only 1 transaction
IF REVERSAL
SET POSITION=1
+14 DO LOG^ABSPOSL("RESPONSE - #"_RESPIEN_", POSITION="_POSITION)
+15 ;IHS/OIT/SCR 2/13/09 patch 29 modify next line to avoid undefined error is no such node exists
+16 ;I '$D(^ABSPR(RESPIEN,1000,POSITION,500)) S ERROR=1 G RESPBAD
+17 ;IHS/OIT/SCR 05/12/09 start changes to avoid continued undefined problems patch 31
+18 IF $GET(POSITION)=""
Begin DoDot:1
+19 SET ERROR=1
+20 DO RESPBAD
+21 QUIT
End DoDot:1
+22 IF ERROR
QUIT
+23 IF $GET(^ABSPR(RESPIEN,1000,POSITION,500))=""
Begin DoDot:1
+24 SET ERROR=1
+25 DO RESPBAD
+26 QUIT
End DoDot:1
+27 IF ERROR
QUIT
+28 ;IHS/OIT/SCR 05/12/09 end changes to avoid continued undefined problems patch 31
+29 NEW RESP
SET RESP=$PIECE(^ABSPR(RESPIEN,1000,POSITION,500),U)
+30 DO INCSTAT^ABSPOSUD("R",$SELECT(RESP="R":2,RESP="P":3,RESP="D":4,RESP="C":5,1:19))
+31 Begin DoDot:1
+32 NEW X
SET X="RESPONSE - Position "_POSITION_" = "_RESP
+33 IF RESP="P"
SET X=X_" $"_$$INSPAID1^ABSPOS03(RESPIEN,POSITION)
+34 DO LOG^ABSPOSL(X)
End DoDot:1
+35 ;
+36 ;IHS/SD/lwj 10/07/02 NCPDP 5.1 changes - look at field 526
+37 ; (additional message) if nothing found in 504
+38 NEW X
SET X=$GET(^ABSPR(RESPIEN,1000,POSITION,504))
+39 ;IHS/SD/lwj 10/07/02
IF X=""
SET X=$GET(^ABSPR(RESPIEN,1000,POSITION,526))
+40 IF X]""
DO LOG^ABSPOSL("RESPONSE - MESSAGE - "_X)
+41 ;
+42 ; rejected, give rejection reasons
IF RESP="R"
Begin DoDot:1
+43 NEW J
SET J=0
FOR
SET J=$ORDER(^ABSPR(RESPIEN,1000,POSITION,511,J))
IF 'J
QUIT
Begin DoDot:2
+44 NEW R
SET R=$PIECE($GET(^ABSPR(RESPIEN,1000,POSITION,511,J,0)),U)
+45 NEW X
IF R]""
Begin DoDot:3
+46 SET X=$ORDER(^ABSPF(9002313.93,"B",R,0))
+47 IF X]""
SET X=$PIECE($GET(^ABSPF(9002313.93,X,0)),U,2)
End DoDot:3
+48 IF '$TEST
SET X=""
+49 DO LOG^ABSPOSL("REJECT - "_R_" - "_X)
End DoDot:2
End DoDot:1
+50 ;
+51 NEW INSURER
SET INSURER=$PIECE(^ABSPT(ABSBRXI,1),U,6)
+52 ;IHS/OIT/SCR 061809 patch 32 - if no insurer,process as corrupted response
IF $GET(INSURER)=""
DO RESPBAD
QUIT
+53 ; ins. asleep: want to retry
IF $$REJSLEEP^ABSPOSQ4(RESPIEN,POSITION)
Begin DoDot:1
+54 DO SETSTAT^ABSPOSU(31)
+55 NEW X
SET X=$$INCSLEEP^ABSPOSQ4(INSURER)
+56 SET $PIECE(^ABSPT(IEN59,8),U)=X_U_U_INSURER
+57 DO LOG^ABSPOSL($TEXT(+0)_" - Insurer asleep; retry scheduled for "_X)
End DoDot:1
+58 ; else: a normal kind of response, so we are done
IF '$TEST
Begin DoDot:1
+59 DO CLRSLEEP^ABSPOSQ4(INSURER,1)
+60 ; "Done"
DO SETSTAT^ABSPOSU(99)
+61 IF $GET(^ABSPT(ABSBRXI,3))
Begin DoDot:2
+62 DO SETRESU^ABSPOSU(0,"Cancellation tried too late; claim sent.")
End DoDot:2
+63 IF '$TEST
Begin DoDot:2
+64 ; indicates a complete response was received
DO SETRESU^ABSPOSU(0)
End DoDot:2
End DoDot:1
+65 ; status reports should refer to the ^ABSPR entry
+66 DO RELSLOT^ABSPOSL
+67 QUIT
RESPBAD ; corrupted response escape from RESP1 ; reached by a GOTO
+1 NEW MSG
SET MSG="Corrupted response `"_RESPIEN
+2 ; "Done"
DO SETSTAT^ABSPOSU(99)
+3 DO SETRESU^ABSPOSU(6500+$GET(ERROR),MSG)
+4 DO LOG^ABSPOSL(MSG)
+5 ; close up the logging slot
DO DONE^ABSPOSL
+6 QUIT
