ABSPOSJ2 ;IHS/OIT/SCR - pre and post init for V1.0 patch 28 [ 10/31/2002 10:58 AM ]
;;1.0;Pharmacy Point of Sale;**29,39,43,44,45,46,47,48**;Jun 21,2001;Build 38
;
; Pre and Post init routine use in absp0100.29k
;------------------------------------------------------------------
;
; Pre and Post init routine to use in absp0100.29k
;
; Purpose of new subroutines:
; the routine ABSPOSJ1 contained routines to process claims in the ABSPHOLD fild
; and then delete that file upon completion. Patch 29 isolates this functionality
; from other pre and post functions to reduce the file size and because this code
; is suspected of not working well for at least some sites
;
;IHS/OIT/SCR = 09/22/08 - Patch 28
; look for HELD claims in pre-init routines and print report if they are there
; Remove file ^ABSPHOLD in post-init routine
; Remove outdated comments to get routine block size under 1500
; ;------------------------------------------------------------------
;IHS/OIT/SCR = 02/06/09 - Patch 29
; Remove OPTION 'ABSP MEDICARE PART D ELIG CHK' from OPTION 'ABSP MENU RPT CLAIM STATUS'
; in post install since it doesn't go away with the new menu
; =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
; /IHS/OIT/RAM ; 19 MAY 2017 ; CR 07534 - I don't think that this file is actively used, but as there's no documentation
; stating that it *isn't* used, I'm adding the change required for the sending the insurance information to 3PB here as well.
; However, I'm not recreating _all_ the code; I'm calling the function $$GETINSINFO^ABSPOSBB to gather the info.
Q
;IHS/OIT/SCR 09/22/08 Patch 28 - remove release any HELD claims START new code
HOLDCHK ;
N ABSPCHK,ABSPHIEN
S ABSPCHK=$O(^ABSPHOLD(0))
I ABSPCHK D
.D MES^XPDUTL("There are claims in the HOLD Queue which is being eliminated!")
.D MES^XPDUTL("These claims are being released from the HOLD status")
.S ABSPHIEN=0
.;now release for processing
.F S ABSPHIEN=$O(^ABSPHOLD(ABSPHIEN)) Q:'+ABSPHIEN D CHKHOLD(ABSPHIEN)
Q
; taken from ABSPOSBH
CHKHOLD(HOLDIEN) ; Process to check the hold claim.
N HOLD57,HOLDTYP,HOLDREC,HOLDLOC,HOLDVDT,HOLDINS,HOLDFLG,HOLDDA
S HOLD57=$P($G(^ABSPHOLD(HOLDIEN,0)),U)
S HOLDTYP=$P($G(^ABSPHOLD(HOLDIEN,0)),U,2)
I HOLDTYP="P" D
. S HOLDREC=$G(^ABSPHOLD(HOLDIEN,"P"))
. S HOLDLOC=$P(HOLDREC,U,7)
. S HOLDVDT=$P(HOLDREC,U,4)
. S HOLDINS=$P(HOLDREC,U,8)
I HOLDTYP="R" D
. S HOLDREC=$G(^ABSPHOLD(HOLDIEN,"R"))
. S HOLDLOC=$P(HOLDREC,U,1)
. S HOLDVDT=$P(HOLDREC,U,2)
. S HOLDINS=$P(HOLDREC,U,3)
I HOLDTYP'="P"&(HOLDTYP'="R") Q
I HOLDTYP="P" D POSTIT
I HOLDTYP="R" D REVERSIT
;
I HOLDDA]"" D
. N FDA,IEN,MSG
. S FDA(9002313.57,HOLD57_",",.15)=HOLDDA
. D FILE^DIE(,"FDA","MSG")
. I $D(MSG) D LOG^ABSPOSL2("CHKHOLD^ABSPOSJ2",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
D ^XBFMK ;kill FileMan variables
S DIK="^ABSPHOLD("
S DA=HOLDIEN
D ^DIK
;
Q
POSTIT ;
N ABSP,ABSPOST,HOLDREC2,ABSPINS ; /IHS/OIT/RAM ; 19 MAY 2017 ; ADDED NEW VARIABLE FOR INSURANCE INFO.
;
S ABSP(.21)=$P(HOLDREC,U,1) ; Bill amount
S ABSP(.23)=$P(HOLDREC,U,2) ; Gross amount
S ABSP(.05)=$P(HOLDREC,U,3) ; Patient
S ABSP(.71)=$P(HOLDREC,U,4) ; Service date from
S ABSP(.72)=$P(HOLDREC,U,5) ; Service date to
S ABSP(.1)=$P(HOLDREC,U,6) ; Clinic
S ABSP(.03)=$P(HOLDREC,U,7) ; Visit location
S ABSP(.08)=$P(HOLDREC,U,8) ; Active insurer
S ABSP(.58)=$P(HOLDREC,U,9) ; Prior Authorization
S ABSP(.14)=$P(HOLDREC,U,10) ; Approving Official
S HOLDREC2=$G(^ABSPHOLD(HOLDIEN,"P2"))
S ABSP(41,.01)=$P(HOLDREC2,U,1) ; Provider
S ABSP(23,.01)=$P(HOLDREC2,U,2) ; Medication
S ABSP(23,.03)=$P(HOLDREC2,U,3) ; Quantity
S ABSP(23,.04)=$P(HOLDREC2,U,4) ; Unit Price
S ABSP(23,.05)=$P(HOLDREC2,U,5) ; Dispensing Fee
S ABSP(23,19)=$P(HOLDREC2,U,6) ; New/Refill code
S ABSP(23,.06)=$P(HOLDREC2,U,7) ; Prescription
S ABSP(23,14)=$P(HOLDREC2,U,8) ; Date filled
S ABSP(23,20)=$P(HOLDREC2,U,9) ; Days supply
; /IHS/OIT/RAM ; 18 MAY 2017 ; CR 07534 - Pass Insurer Information to 3PB. All code that follows until end comment is new for Patch 48.
S ABSPINS=$$GETINSINFO^ABSPOSBB(HOLD57) ; Gather all available insurance information for xfer to 3PB.
; As they say... plan for the worst, hope for the best. Just in case more info needs to be returned than the PRVT multiple, uncomment any needed info from the possibilities below.
; I +$P(ABSPINS,U,1)>0 S ABSP(13,.01)=$P(ABSPINS,U,1) ; Insurer pointer from the 701/702/703 field of ^ABSPTL.
; I +$P(ABSPINS,U,4)>0 S ABSP(13,.04)=$P(ABSPINS,U,4) ; Medicare multiple from the 601/602/603 field of ^ABSPTL.
; I +$P(ABSPINS,U,5)>0 S ABSP(13,.05)=$P(ABSPINS,U,5) ; Railroad multiple from the 601/602/603 field of ^ABSPTL.
; I +$P(ABSPINS,U,6)>0 S ABSP(13,.06)=$P(ABSPINS,U,6) ; Medicaid Eligible pointer from the 601/602/603 field of ^ABSPTL.
; I +$P(ABSPINS,U,7)>0 S ABSP(13,.07)=$P(ABSPINS,U,7) ; Medicaid multiple from the 601/602/603 field of ^ABSPTL.
I +$P(ABSPINS,U,8)>0 S ABSP(13,.08)=$P(ABSPINS,U,8) ; Private Insurance multiple from the 601/602/603 field of ^ABSPTL.
; /IHS/OIT/RAM ; 18 MAY 2017 ; CR 07534 - End of new code detailed above.
S ABSP("OTHIDENT")=$P(HOLDREC2,U,10) ; Other Bill Identifier
S INSDFN=ABSP(.08)
D LOG^ABSPOSL("Posting transaction "_HOLD57_".")
S ABSPOST=$$EN^ABMPSAPI(.ABSP) ; Call published 3PB API
D SETFLAG(HOLD57,0) ; clear the "needs billing" flag
S HOLDDA=ABSPOST
Q
REVERSIT ;
N ABSP,ABSPWOFF,ABSCAN
S ABSP("CREDIT")=$P(HOLDREC,U,4) ; $$ to reverse
S ABSP("ARLOC")=$P(HOLDREC,U,5) ; A/R Bill location
S ABSP("TRAN TYPE")=$P(HOLDREC,U,6) ; Adjustment
S ABSP("ADJ CAT")=$P(HOLDREC,U,7) ; Write off
S ABSP("ADJ TYPE")=$P(HOLDREC,U,8) ; Billed in error
S ABSP("USER")=$P(HOLDREC,U,9) ; User who entered tran
D LOG^ABSPOSL("Reversing transaction "_HOLD57_".")
S ABSPWOFF=$$EN^BARPSAPI(.ABSP) ; Call published A/R API
S ABSCAN=$$CAN^ABMPSAPI(ABSPWOFF) ; Cancel bill in 3PB
D SETFLAG(HOLD57,0) ; clear the "needs billing" flag
S HOLDDA=ABSPWOFF
Q
SETFLAG(IEN57,VALUE) ;EP -
D
. N FDA,MSG ; clear the "needs billing" flag
. S FDA(9002313.57,IEN57_",",.16)=VALUE
SF1 . D FILE^DIE(,"FDA","MSG")
. I $D(MSG) D LOG^ABSPOSL2("SF1^ABSPOSJ2",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
Q
;IHS/OIT/CNI/RAN Following two routines added for PATCH 39.
CLNREJ ;Clean out the unrecognized reject codes in response file.
N RESP,NUMB,RJNUMB,RJCTCODE,COUNT
S RESP=""
F S RESP=$O(^ABSPR(RESP)) Q:RESP="" D
. Q:'$D(^ABSPR(RESP,1000))
. S NUMB=0
. F S NUMB=$O(^ABSPR(RESP,1000,NUMB)) Q:+NUMB=0 D
. . Q:'$D(^ABSPR(RESP,1000,NUMB,511))
. . S RJNUMB=0
. . F S RJNUMB=$O(^ABSPR(RESP,1000,NUMB,511,RJNUMB)) Q:+RJNUMB=0 D
. . . S RJCTCODE=$G(^ABSPR(RESP,1000,NUMB,511,RJNUMB,0))
. . . I RJCTCODE[" " D CLEANUP(RESP,NUMB,RJNUMB,RJCTCODE)
Q
;
CLEANUP(RESP,NUMB,RJNUMB,RJCTCODE) ;Clean up that particular resp file entry
N NRJCTCD,DR,DA,DIE
S NRJCTCD=$TR(RJCTCODE," ","")
S DR=".01////"_NRJCTCD
S DA(2)=RESP
S DA(1)=NUMB
S DA=RJNUMB
S DIE="^ABSPR("_DA(2)_",1000,"_DA(1)_",511,"
L +^ABSPR(DA(2)):0 I $T D ^DIE L -^ABSPR(DA(2))
Q
;
CLNREV ;IHS/OIT/RCS 3/2/2012 patch 43 run fix for errored reversals
I '$D(^ABSP(9002313.99,1,"ABSPREVF")) D ;Run once
. D MES^XPDUTL("Running reversal transaction fix...")
. N CLM,X,CLMN
. S CLM=0
. F S CLM=$O(^ABSPC(CLM)) Q:CLM=""!(CLM'?1N.N) D
. . S X=$G(^ABSPC(CLM,100)) I X="" Q
. . S CLMN=$P($G(^ABSPC(CLM,0)),U) I CLMN="" Q
. . I CLMN'["R" Q
. . I $P(X,U,2)="D0",$P(X,U,3)=11 S $P(X,U,3)="B2",^ABSPC(CLM,100)=X ;Reset Transaction type to 'B2'
. . I $P(X,U,9)<2 Q ;Reversal Transaction count not greated than 1
. . S $P(X,U,9)=1,^ABSPC(CLM,100)=X ;Reset Transaction count to '1'
. . S X=$G(^ABSPC(CLM,"M",1,0)) I X="" Q
. . S X=$E(X,1,20)_1_$E(X,22,999),^ABSPC(CLM,"M",1,0)=X ;Reset Transaction count to '1' in raw data record
. S ^ABSP(9002313.99,1,"ABSPREVF")=1
Q
;
DIAL ;IHS/OIT/RCS 8/31/2012 patch 44 fix for DIALOUT field - HEAT # 82109
;Field should not be left blank and should have ENVOY DIRECT VIA T1 LINE
N INSIEN,X,DIAL
S INSIEN="" F S INSIEN=$O(^ABSPEI(INSIEN)) Q:INSIEN="" D
. S X=$G(^ABSPEI(INSIEN,100)) I X="" Q ;PARTIAL SETUP
. S DIAL=$P(X,U,7) I DIAL'="" Q ;ALREADY DATA IS FIELD
. S $P(X,U,7)=9,^ABSPEI(INSIEN,100)=X ;SET DIALOUT VALUE TO '9'-ENVOY DIRECT VIA T1 LINE
Q
;
DEF ;IHS/OIT/RCS 11/28/2012 patch 45 Add ICD10 General POS Default date
N DEF
S DEF=$G(^ABSP(9002313.99,1,"ICD10")) I DEF'="" Q ;ALREADY DATA IS FIELD
S ^ABSP(9002313.99,1,"ICD10")=3141001 ;SET ICD10 DEFAULT DATE TO '10/1/2014'
Q
;
DEF2 ;IHS/OIT/RCS 04/08/2014 patch 47 Change to new ICD10 General POS Default date
N DEF
S DEF=$G(^ABSP(9002313.99,1,"ICD10")) I DEF'="" Q:DEF'=3141001 ;Date was changed by user
S ^ABSP(9002313.99,1,"ICD10")=3151001 ;SET ICD10 DEFAULT DATE TO '10/1/2015'
Q
;
DOL ;IHS/OIT/RCS 11/28/2012 patch 46 Add default Maximum Dollar limit
N DOL
S DOL=$G(^ABSP(9002313.99,1,"DOLLMT")) I DOL'="" Q ;ALREADY DATA IS FIELD
S ^ABSP(9002313.99,1,"DOLLMT")=15000 ;SET Maximum Dollar Limit to $15,000
Q
;
MCAR ;IHS/OIT/RCS 11/28/2012 patch 46 Check Medicare Part-D Insurers for fields 147 and 384
I $G(^ABSP(9002313.99,1,"ABSPMCAR")) Q ;Run once
N INS,X,AR,F147
S F147=""
;Find IEN of fields to be Unsuppressed and set into AR
S X=$O(^ABSPF(9002313.91,"B",147,"")) I X]"" S AR(X)="",F147=X
S X=$O(^ABSPF(9002313.91,"B",384,"")) I X]"" S AR(X)=""
;
S INS=0,U="^" F S INS=$O(^ABSPEI(INS)) Q:INS="" D
.S X=$G(^ABSPEI(INS,100)) I '$P(X,U,18) Q ;Not Part D so skip it
.I '$P(X,U,16) Q ;No BIN # so skip it
.D UNS ;Check for Suppressed Fields
S ^ABSP(9002313.99,1,"ABSPMCAR")=1
Q
;
UNS ;Unsuppress function
N IEN,I,FL,Y,LST,CT
S IEN="",FL=0 F S IEN=$O(AR(IEN)) Q:IEN="" D
.I '$D(^ABSPEI(INS,220,"B",IEN)) Q ;Not Suppressed
.S I=0 F S I=$O(^ABSPEI(INS,220,I)) Q:I="" I ^ABSPEI(INS,220,I,0)=IEN K ^ABSPEI(INS,220,I) Q
;
;Check 220 counters/Index
S LST="",CT=0 S I=0 F S I=$O(^ABSPEI(INS,220,I)) Q:I=""!(I'?1N.N) S LST=I,CT=CT+1
S Y=^ABSPEI(INS,220,0),$P(Y,U,3)=LST,$P(Y,U,4)=CT,^ABSPEI(INS,220,0)=Y
K ^ABSPEI(INS,220,"B")
S I=0 F S I=$O(^ABSPEI(INS,220,I)) Q:I="" S VAL=$G(^ABSPEI(INS,220,I,0)) I VAL]"" D
.S ^ABSPEI(INS,220,"B",VAL,I)=""
;
;Check 210 counters/Index
S LST="",CT=0 S I=0 F S I=$O(^ABSPEI(INS,210,I)) Q:I=""!(I'?1N.N) S LST=I,CT=CT+1
S Y=^ABSPEI(INS,210,0),$P(Y,U,3)=LST,$P(Y,U,4)=CT,^ABSPEI(INS,210,0)=Y
K ^ABSPEI(INS,210,"B")
S I=0 F S I=$O(^ABSPEI(INS,210,I)) Q:I="" S VAL=$G(^ABSPEI(INS,210,I,0)) I VAL]"" D
.S ^ABSPEI(INS,210,"B",VAL,I)=""
Q
;
RESTORE ;EP - Post init routine for absp0100.03k.
; This subroutine will take the values stored in the save global
; created in the above "SAVE" subroutine and restore the values
; in their new locations in the ^ABSPC file.
N CLMIEN,MEDIEN,RTN,REC,LAST,I
S (LAST,MEDIEN,CLMIEN)=""
S RTN="ABSPOSJ1"
; if we have to restart - this is where we need to start
S LAST=$G(^ABSPOSXX(RTN,"LAST PROCESSED"))
I LAST'="" D
. S CLMIEN=$P(LAST,U)
. S MEDIEN=$P(LAST,U,2)
F S CLMIEN=$O(^ABSPOSXX(RTN,CLMIEN)) Q:CLMIEN="" D
. D RST320
. F S MEDIEN=$O(^ABSPOSXX(RTN,CLMIEN,400,MEDIEN)) Q:MEDIEN="" D
.. S REC=$G(^ABSPOSXX(RTN,CLMIEN,400,MEDIEN,400))
.. Q:REC=""
.. F I=31:1:43 D MOVFLD^ABSPOSJ1(I+400,$P(REC,U,I))
.. S ^ABSPOSXX(RTN,"LAST PROCESSED")=CLMIEN_"^"_MEDIEN
Q
RST320 ; this will restore the 320 value onto the 320 node, piece 20
N FDA,MSG,VALUE
S VALUE=$P($G(^ABSPOSXX(RTN,CLMIEN,320)),U)
Q:VALUE=""
S FDA(9002313.02,CLMIEN_",",320)=VALUE
D FILE^DIE(,"FDA","MSG")
I $D(MSG) D LOG^ABSPOSL2("RST320^ABSPOSJ2",.MSG) ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
Q
ABSPOSJ2 ;IHS/OIT/SCR - pre and post init for V1.0 patch 28 [ 10/31/2002 10:58 AM ]
+1 ;;1.0;Pharmacy Point of Sale;**29,39,43,44,45,46,47,48**;Jun 21,2001;Build 38
+2 ;
+3 ; Pre and Post init routine use in absp0100.29k
+4 ;------------------------------------------------------------------
+5 ;
+6 ; Pre and Post init routine to use in absp0100.29k
+7 ;
+8 ; Purpose of new subroutines:
+9 ; the routine ABSPOSJ1 contained routines to process claims in the ABSPHOLD fild
+10 ; and then delete that file upon completion. Patch 29 isolates this functionality
+11 ; from other pre and post functions to reduce the file size and because this code
+12 ; is suspected of not working well for at least some sites
+13 ;
+14 ;IHS/OIT/SCR = 09/22/08 - Patch 28
+15 ; look for HELD claims in pre-init routines and print report if they are there
+16 ; Remove file ^ABSPHOLD in post-init routine
+17 ; Remove outdated comments to get routine block size under 1500
+18 ; ;------------------------------------------------------------------
+19 ;IHS/OIT/SCR = 02/06/09 - Patch 29
+20 ; Remove OPTION 'ABSP MEDICARE PART D ELIG CHK' from OPTION 'ABSP MENU RPT CLAIM STATUS'
+21 ; in post install since it doesn't go away with the new menu
+22 ; =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
+23 ; /IHS/OIT/RAM ; 19 MAY 2017 ; CR 07534 - I don't think that this file is actively used, but as there's no documentation
+24 ; stating that it *isn't* used, I'm adding the change required for the sending the insurance information to 3PB here as well.
+25 ; However, I'm not recreating _all_ the code; I'm calling the function $$GETINSINFO^ABSPOSBB to gather the info.
+26 QUIT
+27 ;IHS/OIT/SCR 09/22/08 Patch 28 - remove release any HELD claims START new code
HOLDCHK ;
+1 NEW ABSPCHK,ABSPHIEN
+2 SET ABSPCHK=$ORDER(^ABSPHOLD(0))
+3 IF ABSPCHK
Begin DoDot:1
+4 DO MES^XPDUTL("There are claims in the HOLD Queue which is being eliminated!")
+5 DO MES^XPDUTL("These claims are being released from the HOLD status")
+6 SET ABSPHIEN=0
+7 ;now release for processing
+8 FOR
SET ABSPHIEN=$ORDER(^ABSPHOLD(ABSPHIEN))
IF '+ABSPHIEN
QUIT
DO CHKHOLD(ABSPHIEN)
End DoDot:1
+9 QUIT
+10 ; taken from ABSPOSBH
CHKHOLD(HOLDIEN) ; Process to check the hold claim.
+1 NEW HOLD57,HOLDTYP,HOLDREC,HOLDLOC,HOLDVDT,HOLDINS,HOLDFLG,HOLDDA
+2 SET HOLD57=$PIECE($GET(^ABSPHOLD(HOLDIEN,0)),U)
+3 SET HOLDTYP=$PIECE($GET(^ABSPHOLD(HOLDIEN,0)),U,2)
+4 IF HOLDTYP="P"
Begin DoDot:1
+5 SET HOLDREC=$GET(^ABSPHOLD(HOLDIEN,"P"))
+6 SET HOLDLOC=$PIECE(HOLDREC,U,7)
+7 SET HOLDVDT=$PIECE(HOLDREC,U,4)
+8 SET HOLDINS=$PIECE(HOLDREC,U,8)
End DoDot:1
+9 IF HOLDTYP="R"
Begin DoDot:1
+10 SET HOLDREC=$GET(^ABSPHOLD(HOLDIEN,"R"))
+11 SET HOLDLOC=$PIECE(HOLDREC,U,1)
+12 SET HOLDVDT=$PIECE(HOLDREC,U,2)
+13 SET HOLDINS=$PIECE(HOLDREC,U,3)
End DoDot:1
+14 IF HOLDTYP'="P"&(HOLDTYP'="R")
QUIT
+15 IF HOLDTYP="P"
DO POSTIT
+16 IF HOLDTYP="R"
DO REVERSIT
+17 ;
+18 IF HOLDDA]""
Begin DoDot:1
+19 NEW FDA,IEN,MSG
+20 SET FDA(9002313.57,HOLD57_",",.15)=HOLDDA
+21 DO FILE^DIE(,"FDA","MSG")
+22 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("CHKHOLD^ABSPOSJ2",.MSG)
End DoDot:1
+23 ;kill FileMan variables
DO ^XBFMK
+24 SET DIK="^ABSPHOLD("
+25 SET DA=HOLDIEN
+26 DO ^DIK
+27 ;
+28 QUIT
POSTIT ;
+1 ; /IHS/OIT/RAM ; 19 MAY 2017 ; ADDED NEW VARIABLE FOR INSURANCE INFO.
NEW ABSP,ABSPOST,HOLDREC2,ABSPINS
+2 ;
+3 ; Bill amount
SET ABSP(.21)=$PIECE(HOLDREC,U,1)
+4 ; Gross amount
SET ABSP(.23)=$PIECE(HOLDREC,U,2)
+5 ; Patient
SET ABSP(.05)=$PIECE(HOLDREC,U,3)
+6 ; Service date from
SET ABSP(.71)=$PIECE(HOLDREC,U,4)
+7 ; Service date to
SET ABSP(.72)=$PIECE(HOLDREC,U,5)
+8 ; Clinic
SET ABSP(.1)=$PIECE(HOLDREC,U,6)
+9 ; Visit location
SET ABSP(.03)=$PIECE(HOLDREC,U,7)
+10 ; Active insurer
SET ABSP(.08)=$PIECE(HOLDREC,U,8)
+11 ; Prior Authorization
SET ABSP(.58)=$PIECE(HOLDREC,U,9)
+12 ; Approving Official
SET ABSP(.14)=$PIECE(HOLDREC,U,10)
+13 SET HOLDREC2=$GET(^ABSPHOLD(HOLDIEN,"P2"))
+14 ; Provider
SET ABSP(41,.01)=$PIECE(HOLDREC2,U,1)
+15 ; Medication
SET ABSP(23,.01)=$PIECE(HOLDREC2,U,2)
+16 ; Quantity
SET ABSP(23,.03)=$PIECE(HOLDREC2,U,3)
+17 ; Unit Price
SET ABSP(23,.04)=$PIECE(HOLDREC2,U,4)
+18 ; Dispensing Fee
SET ABSP(23,.05)=$PIECE(HOLDREC2,U,5)
+19 ; New/Refill code
SET ABSP(23,19)=$PIECE(HOLDREC2,U,6)
+20 ; Prescription
SET ABSP(23,.06)=$PIECE(HOLDREC2,U,7)
+21 ; Date filled
SET ABSP(23,14)=$PIECE(HOLDREC2,U,8)
+22 ; Days supply
SET ABSP(23,20)=$PIECE(HOLDREC2,U,9)
+23 ; /IHS/OIT/RAM ; 18 MAY 2017 ; CR 07534 - Pass Insurer Information to 3PB. All code that follows until end comment is new for Patch 48.
+24 ; Gather all available insurance information for xfer to 3PB.
SET ABSPINS=$$GETINSINFO^ABSPOSBB(HOLD57)
+25 ; As they say... plan for the worst, hope for the best. Just in case more info needs to be returned than the PRVT multiple, uncomment any needed info from the possibilities below.
+26 ; I +$P(ABSPINS,U,1)>0 S ABSP(13,.01)=$P(ABSPINS,U,1) ; Insurer pointer from the 701/702/703 field of ^ABSPTL.
+27 ; I +$P(ABSPINS,U,4)>0 S ABSP(13,.04)=$P(ABSPINS,U,4) ; Medicare multiple from the 601/602/603 field of ^ABSPTL.
+28 ; I +$P(ABSPINS,U,5)>0 S ABSP(13,.05)=$P(ABSPINS,U,5) ; Railroad multiple from the 601/602/603 field of ^ABSPTL.
+29 ; I +$P(ABSPINS,U,6)>0 S ABSP(13,.06)=$P(ABSPINS,U,6) ; Medicaid Eligible pointer from the 601/602/603 field of ^ABSPTL.
+30 ; I +$P(ABSPINS,U,7)>0 S ABSP(13,.07)=$P(ABSPINS,U,7) ; Medicaid multiple from the 601/602/603 field of ^ABSPTL.
+31 ; Private Insurance multiple from the 601/602/603 field of ^ABSPTL.
IF +$PIECE(ABSPINS,U,8)>0
SET ABSP(13,.08)=$PIECE(ABSPINS,U,8)
+32 ; /IHS/OIT/RAM ; 18 MAY 2017 ; CR 07534 - End of new code detailed above.
+33 ; Other Bill Identifier
SET ABSP("OTHIDENT")=$PIECE(HOLDREC2,U,10)
+34 SET INSDFN=ABSP(.08)
+35 DO LOG^ABSPOSL("Posting transaction "_HOLD57_".")
+36 ; Call published 3PB API
SET ABSPOST=$$EN^ABMPSAPI(.ABSP)
+37 ; clear the "needs billing" flag
DO SETFLAG(HOLD57,0)
+38 SET HOLDDA=ABSPOST
+39 QUIT
REVERSIT ;
+1 NEW ABSP,ABSPWOFF,ABSCAN
+2 ; $$ to reverse
SET ABSP("CREDIT")=$PIECE(HOLDREC,U,4)
+3 ; A/R Bill location
SET ABSP("ARLOC")=$PIECE(HOLDREC,U,5)
+4 ; Adjustment
SET ABSP("TRAN TYPE")=$PIECE(HOLDREC,U,6)
+5 ; Write off
SET ABSP("ADJ CAT")=$PIECE(HOLDREC,U,7)
+6 ; Billed in error
SET ABSP("ADJ TYPE")=$PIECE(HOLDREC,U,8)
+7 ; User who entered tran
SET ABSP("USER")=$PIECE(HOLDREC,U,9)
+8 DO LOG^ABSPOSL("Reversing transaction "_HOLD57_".")
+9 ; Call published A/R API
SET ABSPWOFF=$$EN^BARPSAPI(.ABSP)
+10 ; Cancel bill in 3PB
SET ABSCAN=$$CAN^ABMPSAPI(ABSPWOFF)
+11 ; clear the "needs billing" flag
DO SETFLAG(HOLD57,0)
+12 SET HOLDDA=ABSPWOFF
+13 QUIT
SETFLAG(IEN57,VALUE) ;EP -
+1 Begin DoDot:1
+2 ; clear the "needs billing" flag
NEW FDA,MSG
+3 SET FDA(9002313.57,IEN57_",",.16)=VALUE
SF1 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("SF1^ABSPOSJ2",.MSG)
End DoDot:1
+2 QUIT
+3 ;IHS/OIT/CNI/RAN Following two routines added for PATCH 39.
CLNREJ ;Clean out the unrecognized reject codes in response file.
+1 NEW RESP,NUMB,RJNUMB,RJCTCODE,COUNT
+2 SET RESP=""
+3 FOR
SET RESP=$ORDER(^ABSPR(RESP))
IF RESP=""
QUIT
Begin DoDot:1
+4 IF '$DATA(^ABSPR(RESP,1000))
QUIT
+5 SET NUMB=0
+6 FOR
SET NUMB=$ORDER(^ABSPR(RESP,1000,NUMB))
IF +NUMB=0
QUIT
Begin DoDot:2
+7 IF '$DATA(^ABSPR(RESP,1000,NUMB,511))
QUIT
+8 SET RJNUMB=0
+9 FOR
SET RJNUMB=$ORDER(^ABSPR(RESP,1000,NUMB,511,RJNUMB))
IF +RJNUMB=0
QUIT
Begin DoDot:3
+10 SET RJCTCODE=$GET(^ABSPR(RESP,1000,NUMB,511,RJNUMB,0))
+11 IF RJCTCODE[" "
DO CLEANUP(RESP,NUMB,RJNUMB,RJCTCODE)
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
CLEANUP(RESP,NUMB,RJNUMB,RJCTCODE) ;Clean up that particular resp file entry
+1 NEW NRJCTCD,DR,DA,DIE
+2 SET NRJCTCD=$TRANSLATE(RJCTCODE," ","")
+3 SET DR=".01////"_NRJCTCD
+4 SET DA(2)=RESP
+5 SET DA(1)=NUMB
+6 SET DA=RJNUMB
+7 SET DIE="^ABSPR("_DA(2)_",1000,"_DA(1)_",511,"
+8 LOCK +^ABSPR(DA(2)):0
IF $TEST
DO ^DIE
LOCK -^ABSPR(DA(2))
+9 QUIT
+10 ;
CLNREV ;IHS/OIT/RCS 3/2/2012 patch 43 run fix for errored reversals
+1 ;Run once
IF '$DATA(^ABSP(9002313.99,1,"ABSPREVF"))
Begin DoDot:1
+2 DO MES^XPDUTL("Running reversal transaction fix...")
+3 NEW CLM,X,CLMN
+4 SET CLM=0
+5 FOR
SET CLM=$ORDER(^ABSPC(CLM))
IF CLM=""!(CLM'?1N.N)
QUIT
Begin DoDot:2
+6 SET X=$GET(^ABSPC(CLM,100))
IF X=""
QUIT
+7 SET CLMN=$PIECE($GET(^ABSPC(CLM,0)),U)
IF CLMN=""
QUIT
+8 IF CLMN'["R"
QUIT
+9 ;Reset Transaction type to 'B2'
IF $PIECE(X,U,2)="D0"
IF $PIECE(X,U,3)=11
SET $PIECE(X,U,3)="B2"
SET ^ABSPC(CLM,100)=X
+10 ;Reversal Transaction count not greated than 1
IF $PIECE(X,U,9)<2
QUIT
+11 ;Reset Transaction count to '1'
SET $PIECE(X,U,9)=1
SET ^ABSPC(CLM,100)=X
+12 SET X=$GET(^ABSPC(CLM,"M",1,0))
IF X=""
QUIT
+13 ;Reset Transaction count to '1' in raw data record
SET X=$EXTRACT(X,1,20)_1_$EXTRACT(X,22,999)
SET ^ABSPC(CLM,"M",1,0)=X
End DoDot:2
+14 SET ^ABSP(9002313.99,1,"ABSPREVF")=1
End DoDot:1
+15 QUIT
+16 ;
DIAL ;IHS/OIT/RCS 8/31/2012 patch 44 fix for DIALOUT field - HEAT # 82109
+1 ;Field should not be left blank and should have ENVOY DIRECT VIA T1 LINE
+2 NEW INSIEN,X,DIAL
+3 SET INSIEN=""
FOR
SET INSIEN=$ORDER(^ABSPEI(INSIEN))
IF INSIEN=""
QUIT
Begin DoDot:1
+4 ;PARTIAL SETUP
SET X=$GET(^ABSPEI(INSIEN,100))
IF X=""
QUIT
+5 ;ALREADY DATA IS FIELD
SET DIAL=$PIECE(X,U,7)
IF DIAL'=""
QUIT
+6 ;SET DIALOUT VALUE TO '9'-ENVOY DIRECT VIA T1 LINE
SET $PIECE(X,U,7)=9
SET ^ABSPEI(INSIEN,100)=X
End DoDot:1
+7 QUIT
+8 ;
DEF ;IHS/OIT/RCS 11/28/2012 patch 45 Add ICD10 General POS Default date
+1 NEW DEF
+2 ;ALREADY DATA IS FIELD
SET DEF=$GET(^ABSP(9002313.99,1,"ICD10"))
IF DEF'=""
QUIT
+3 ;SET ICD10 DEFAULT DATE TO '10/1/2014'
SET ^ABSP(9002313.99,1,"ICD10")=3141001
+4 QUIT
+5 ;
DEF2 ;IHS/OIT/RCS 04/08/2014 patch 47 Change to new ICD10 General POS Default date
+1 NEW DEF
+2 ;Date was changed by user
SET DEF=$GET(^ABSP(9002313.99,1,"ICD10"))
IF DEF'=""
IF DEF'=3141001
QUIT
+3 ;SET ICD10 DEFAULT DATE TO '10/1/2015'
SET ^ABSP(9002313.99,1,"ICD10")=3151001
+4 QUIT
+5 ;
DOL ;IHS/OIT/RCS 11/28/2012 patch 46 Add default Maximum Dollar limit
+1 NEW DOL
+2 ;ALREADY DATA IS FIELD
SET DOL=$GET(^ABSP(9002313.99,1,"DOLLMT"))
IF DOL'=""
QUIT
+3 ;SET Maximum Dollar Limit to $15,000
SET ^ABSP(9002313.99,1,"DOLLMT")=15000
+4 QUIT
+5 ;
MCAR ;IHS/OIT/RCS 11/28/2012 patch 46 Check Medicare Part-D Insurers for fields 147 and 384
+1 ;Run once
IF $GET(^ABSP(9002313.99,1,"ABSPMCAR"))
QUIT
+2 NEW INS,X,AR,F147
+3 SET F147=""
+4 ;Find IEN of fields to be Unsuppressed and set into AR
+5 SET X=$ORDER(^ABSPF(9002313.91,"B",147,""))
IF X]""
SET AR(X)=""
SET F147=X
+6 SET X=$ORDER(^ABSPF(9002313.91,"B",384,""))
IF X]""
SET AR(X)=""
+7 ;
+8 SET INS=0
SET U="^"
FOR
SET INS=$ORDER(^ABSPEI(INS))
IF INS=""
QUIT
Begin DoDot:1
+9 ;Not Part D so skip it
SET X=$GET(^ABSPEI(INS,100))
IF '$PIECE(X,U,18)
QUIT
+10 ;No BIN # so skip it
IF '$PIECE(X,U,16)
QUIT
+11 ;Check for Suppressed Fields
DO UNS
End DoDot:1
+12 SET ^ABSP(9002313.99,1,"ABSPMCAR")=1
+13 QUIT
+14 ;
UNS ;Unsuppress function
+1 NEW IEN,I,FL,Y,LST,CT
+2 SET IEN=""
SET FL=0
FOR
SET IEN=$ORDER(AR(IEN))
IF IEN=""
QUIT
Begin DoDot:1
+3 ;Not Suppressed
IF '$DATA(^ABSPEI(INS,220,"B",IEN))
QUIT
+4 SET I=0
FOR
SET I=$ORDER(^ABSPEI(INS,220,I))
IF I=""
QUIT
IF ^ABSPEI(INS,220,I,0)=IEN
KILL ^ABSPEI(INS,220,I)
QUIT
End DoDot:1
+5 ;
+6 ;Check 220 counters/Index
+7 SET LST=""
SET CT=0
SET I=0
FOR
SET I=$ORDER(^ABSPEI(INS,220,I))
IF I=""!(I'?1N.N)
QUIT
SET LST=I
SET CT=CT+1
+8 SET Y=^ABSPEI(INS,220,0)
SET $PIECE(Y,U,3)=LST
SET $PIECE(Y,U,4)=CT
SET ^ABSPEI(INS,220,0)=Y
+9 KILL ^ABSPEI(INS,220,"B")
+10 SET I=0
FOR
SET I=$ORDER(^ABSPEI(INS,220,I))
IF I=""
QUIT
SET VAL=$GET(^ABSPEI(INS,220,I,0))
IF VAL]""
Begin DoDot:1
+11 SET ^ABSPEI(INS,220,"B",VAL,I)=""
End DoDot:1
+12 ;
+13 ;Check 210 counters/Index
+14 SET LST=""
SET CT=0
SET I=0
FOR
SET I=$ORDER(^ABSPEI(INS,210,I))
IF I=""!(I'?1N.N)
QUIT
SET LST=I
SET CT=CT+1
+15 SET Y=^ABSPEI(INS,210,0)
SET $PIECE(Y,U,3)=LST
SET $PIECE(Y,U,4)=CT
SET ^ABSPEI(INS,210,0)=Y
+16 KILL ^ABSPEI(INS,210,"B")
+17 SET I=0
FOR
SET I=$ORDER(^ABSPEI(INS,210,I))
IF I=""
QUIT
SET VAL=$GET(^ABSPEI(INS,210,I,0))
IF VAL]""
Begin DoDot:1
+18 SET ^ABSPEI(INS,210,"B",VAL,I)=""
End DoDot:1
+19 QUIT
+20 ;
RESTORE ;EP - Post init routine for absp0100.03k.
+1 ; This subroutine will take the values stored in the save global
+2 ; created in the above "SAVE" subroutine and restore the values
+3 ; in their new locations in the ^ABSPC file.
+4 NEW CLMIEN,MEDIEN,RTN,REC,LAST,I
+5 SET (LAST,MEDIEN,CLMIEN)=""
+6 SET RTN="ABSPOSJ1"
+7 ; if we have to restart - this is where we need to start
+8 SET LAST=$GET(^ABSPOSXX(RTN,"LAST PROCESSED"))
+9 IF LAST'=""
Begin DoDot:1
+10 SET CLMIEN=$PIECE(LAST,U)
+11 SET MEDIEN=$PIECE(LAST,U,2)
End DoDot:1
+12 FOR
SET CLMIEN=$ORDER(^ABSPOSXX(RTN,CLMIEN))
IF CLMIEN=""
QUIT
Begin DoDot:1
+13 DO RST320
+14 FOR
SET MEDIEN=$ORDER(^ABSPOSXX(RTN,CLMIEN,400,MEDIEN))
IF MEDIEN=""
QUIT
Begin DoDot:2
+15 SET REC=$GET(^ABSPOSXX(RTN,CLMIEN,400,MEDIEN,400))
+16 IF REC=""
QUIT
+17 FOR I=31:1:43
DO MOVFLD^ABSPOSJ1(I+400,$PIECE(REC,U,I))
+18 SET ^ABSPOSXX(RTN,"LAST PROCESSED")=CLMIEN_"^"_MEDIEN
End DoDot:2
End DoDot:1
+19 QUIT
RST320 ; this will restore the 320 value onto the 320 node, piece 20
+1 NEW FDA,MSG,VALUE
+2 SET VALUE=$PIECE($GET(^ABSPOSXX(RTN,CLMIEN,320)),U)
+3 IF VALUE=""
QUIT
+4 SET FDA(9002313.02,CLMIEN_",",320)=VALUE
+5 DO FILE^DIE(,"FDA","MSG")
+6 ; /IHS/OIT/RAM ; 12 JUN 17 ; AND LOG IT IF AN ERROR OCCURS.
IF $DATA(MSG)
DO LOG^ABSPOSL2("RST320^ABSPOSJ2",.MSG)
+7 QUIT
