Routine: ABSPOSJ2

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.

 ;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)

 ; 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

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

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

SETFLAG(IEN57,VALUE) ;EP -

 . 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.

 ;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)

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))

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

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

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'

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'

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

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

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)=""

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

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.

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

ABSPOSJ2.m