ABMPSAPI ; IHS/ASDS/LSL - 3PB Pharmacy POS API
;;2.6;IHS Third Party Billing System;**2,4,6,10,21**;NOV 12, 2009;Build 379
;
; IHS/ASDS/LSL - 05/17/2001 - V2.4 Patch 6 - New routine to accomodate
; Pharmacy POS. A somewhat generic API to accept info from
; Pharmacy POS to create a bill in Third Party Billing and
; therefore pass to Accounts Receivable.
; IHS/ASDS/LWJ - 06/01/2001 - V2.4 Patch 5 - altered ^DIC call for the
; insurer to no longer access the special lookup routine AUTNKWII
; IHS/ASDS/LSL - 06/14/2001 - V2.4 Patch 5 - Added CAN line tag to
; mark POS bills as cancelled when reversed through POS.
; IHS/ASDS/LSL - 07/18/01 - V2.4 Patch 8
; Resolve <DPARM>CAN+3^ABMPSAPI.
; IHS/SD/SDR - v2.5 p9 - IM15457
; Use visit location for duz(2)
; IHS/SD/SR - v2.5 p9 - IM18926
; Added capability to reprint in TPB on NCPDP format
; IHS/SD/SDR - v2.5 p10 - IM21800
; Fix for <UNDEF>DBFX+10^ABMDEFIP
; IHS/SDR/SDR - v.25 p12 - UFMS
; Changes to log POS claims for UFMS reporting/export
; IHS/SD/SDR - v2.5 p12 - IM25440
; Changed default clinic to 39 (from 25)
; IHS/SD/SDR - v2.5 p13 - IM26096
; Stop cashiering session creation for tribal sites
; and don't display warning message
; IHS/SD/SDR - abm*2.6*4 - NO HEAT - populate INSURER TYPE
; IHS/SD/SDR - abm*2.6*6 - NOHEAT - populate OTHER BILL IDENTIFER in 3P Bill file
;IHS/SD/SDR - 2.6*21 - HEAT118656 - Made change to send back error if A/R Bill isn't found (if it was deleted)
;
Q
;
; *********************************************************************
EN(ABMPOS) ; PEP
; Pass array sub field number. ie: ARRAY(Field #)
; If field is inside a 3P Bill multiple, array needs to be
; ARRAY(Mult #,field #)
;
; ABMPOS(.21) Bill amount
; ABMPOS(.23) Gross amount
; ABMPOS(.05) Patient
; ABMPOS(.71) Service date from
; ABMPOS(.72) Service date to
; ABMPOS(.1) Clinic
; ABMPOS(.03) Visit location
; ABMPOS(.08) Active insurer
; ABMPOS(.58) Pro Authorization number
; ABMPOS(.14) Approving Official
; ABMPOS(11,.01) Visit IEN ;abm*2.6*2
; ABMPOS(41,.01) Provider multiple, Provider
; ABMPOS(23,.01) Pharmacy multiple, Medication
; ABMPOS(23,.03) Pharmacy multiple, units
; ABMPOS(23,.04) Pharmacy multiple, unit cost
; ABMPOS(23,.05) Pharmacy multiple, dispense fee
; ABMPOS(23,19) Pharmacy multiple, new/refill code
; ABMPOS(23,.06) Pharmacy multiple, Prescription
; ABMPOS(23,14) Pharmacy multiple, Date filled
; ABMPOS(23,20) Pharmacy multiple, Days supply
; ABMPOS(73,"REJDATE") POS Rejection Date ;abm*2.6*2
; ABMPOS(73,CNTR,"CODE") POS Rejection Code ;abm*2.6*2
; ABMPOS(73,CNTR,"REASON")POS Rejection Reason ;abm*2.6*2
; ABMPOS("OTHIDENT") Other Bill Identifier for A/R
;
; First determine proper DUZ(2) (code borrowed from claim generator)
; 2 assumptions: 1. Pharmacy and POS do not manipulate DUZ(2) variable
; 2. DUZ(2) is always the parent (box user is on)
K ABMDUZ2,ABMARPS,ABMHOLD,ABMAPOK,ABMBILL,ABMFLD,ABMULT,ABMPASAR
K DINUM,DIC,DA,DIE,X,Y,DD,DO,DLAYGO
S ABMDUZ2=ABMPOS(.03)
S ABMARPS=$P($G(^ABMDPARM(DUZ(2),1,4)),U,9) ; Use A/R parent/sat
; Use A/R parent/sat is yes and visit location not defined under parent
; in A/R Parent/Satellite file.
I ABMARPS,'$D(^BAR(90052.05,DUZ(2),ABMPOS(.03),0)) S ABMDUZ2=ABMPOS(.03)
; Use A/R parent/sat is yes, but DUZ(2) is not the parent for this
; visit location
I ABMARPS,$P($G(^BAR(90052.05,DUZ(2),ABMPOS(.03),0)),U,3)'=DUZ(2) S ABMDUZ2=ABMPOS(.03)
I ABMARPS,$P($G(^BAR(90052.05,DUZ(2),ABMPOS(.03),0)),U,6)>ABMPOS(.71) S ABMDUZ2=ABMPOS(.03)
I ABMARPS,$P($G(^BAR(90052.05,DUZ(2),ABMPOS(.03),0)),U,7),$P(^(0),U,7)<ABMPOS(.71) S ABMDUZ2=ABMPOS(.03)
I '$D(^ABMDPARM(ABMDUZ2,0)) Q "Not in 3P Parameters"
S ABMHOLD=DUZ(2) ; Store DUZ(2)
S DUZ(2)=ABMDUZ2
;
D NOW^%DTC
S ABMPOS(.15)=% ; Date/Time approved = now
S ABMPOS(.02)=131 ; Bill type = outpatient
S ABMPOS(.06)=24 ; export mode NCPDP
S ABMPOS(.07)=901 ; Visit type = 901 (only POS)
S ABMPOS(13,.02)=1 ; Insurer multiple, priority
S ABMPOS(13,.03)="I" ; Insurer multiple, status
S ABMPOS(41,.02)="A" ; Provider multiple, Attending
S ABMPOS(.1)=39 ; always Pharmacy clinic
;
S ABMAPOK=1 ; Pass 3PB to A/R
K DINUM,DIC
S DIC(0)="LX"
S DIC="^ABMDBILL(DUZ(2),"
S X=$$NXNM^ABMDUTL ; Get next Claim number
I 'X S DUZ(2)=ABMHOLD Q "Next claim number unsuccessful"
S X=X_"A" ; Bill number
K DD,DO,DA
S DLAYGO=9002274.4
D ^DIC
I +Y<0 S DUZ(2)=ABMHOLD Q "3P Bill create unsuccessful" ; Bill addition unsuccessful
S (DA,ABMBILL)=+Y
S DIE=DIC
S ABMFLD=0
F S ABMFLD=$O(ABMPOS(ABMFLD)) Q:'+ABMFLD D
.Q:ABMFLD>1
.Q:ABMPOS(ABMFLD)=""
.S DR=ABMFLD_"////"_ABMPOS(ABMFLD)
.D ^DIE
;start new code abm*2.6*4 NOHEAT
;S DR=".22////"_$P($G(^AUTNINS(ABMPOS(.08),2)),U) ;abm*2.6*10 HEAT73780
S DR=".22////"_$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMPOS(.08),".211","I"),1,"I") ;abm*2.6*10 HEAT73780
D ^DIE
;end new code abm*2.6*4 NOHEAT
;start new code abm*2.6*6 NOHEAT
S DR=".115////"_ABMPOS("OTHIDENT")
D ^DIE
;end new code abm*2.6*6 NOHEAT
F ABMULT=13,23,41 D
.K DINUM,DIC,DA
.S DA(1)=ABMBILL
.S DIC("P")=$P(^DD(9002274.4,ABMULT,0),U,2)
.S DIC="^ABMDBILL(DUZ(2),"_DA(1)_","_ABMULT_","
.S DIC(0)="LXIE"
.S X=$S(ABMULT=13:$P(^AUTNINS(INSDFN,0),U),ABMULT=23:$P(^PSDRUG(ABMPOS(23,.01),0),U),1:$P(^VA(200,ABMPOS(41,.01),0),U))
.S DLAYGO=9002274.4
.K DD,DO
.D ^DIC
.I +Y<0 Q ; Addition of multiple unsuccess
.S DA=+Y
.S DIE=DIC
.S ABMFLD=.01
.F S ABMFLD=$O(ABMPOS(ABMULT,ABMFLD)) Q:'+ABMFLD D
..Q:ABMPOS(ABMULT,ABMFLD)=""
..S DR=ABMFLD_"////"_ABMPOS(ABMULT,ABMFLD)
..D ^DIE
;start new code abm*2.6*2
; abm*2.6*2 this section was taken out because it stops other claims from generating.
; Visits are being merged and with this code change, it stops claims from creating that should.
; Needs to be reviewed, further tested, and included in a future patch of ABM.
;K DINUM,DIC,DA,DIE,DR,DIE
;S DA(1)=ABMBILL
;S DIC("P")=$P(^DD(9002274.4,11,0),U,2)
;S DIC="^ABMDBILL(DUZ(2),"_DA(1)_",11,"
;S DIC(0)="LE"
;S X=$G(ABMPOS(11,.01))
;S DLAYGO=9002274.4
;S DIC("DR")=".02////P"
;K DD,DO
;D FILE^DICN
;
K DIC,DIE,DIR,X,Y,DA,DR
I $D(ABMPOS(73)) D ;rejection codes/reasons
.S ABMCNT=0
.F S ABMCNT=$O(ABMPOS(73,ABMCNT)) Q:(+$G(ABMCNT)=0) D
..K DIC,DIE,DIR,DA,DR,X,Y
..S DA(1)=ABMBILL
..S DIC="^ABMDBILL(DUZ(2),"_DA(1)_",73,"
..S DIC(0)="LE"
..S DIC("P")=$P(^DD(9002274.4,73,0),U,2)
..S X=$G(ABMPOS(73,ABMCNT,"CODE"))
..S DIC("DR")=".02////"_$G(ABMPOS(73,ABMCNT,"REASON"))_";.03////"_$G(ABMPOS(73,"REJDATE"))
..K DD,DO
..D ^DIC
;end new code abm*2.6*2
; This DIE call needs to be done last. It's the x-ref on this field
; that creates the bill in A/R from 3PB. It also defines the A/R
; location field on the 3P bill [DUZ(2),DA].
K DIE,DA,DR
S DIE="^ABMDBILL(DUZ(2),"
S DA=ABMBILL
S DR=".04////B" ; Set bill status to B
D ^DIE
S ABMPASAR=$P($G(^ABMDBILL(DUZ(2),ABMBILL,2)),U,6)
I $P($G(^ABMDPARM(DUZ(2),1,4)),U,15)=1 D POSUFMS ;create/populate UFMS Cashiering session
S DUZ(2)=ABMHOLD ; Restore DUZ(2)
K ABMDUZ2,ABMARPS,ABMHOLD,ABMAPOK,ABMBILL,ABMFLD,ABMULT,ABMPOS
K DINUM,DIC,DA,DIE,X,Y,DD,DO,DLAYGO
I ABMPASAR="" Q "A/R Bill population unsuccessful"
Q ABMPASAR ; A/R DUZ(2),IEN
;
; *********************************************************************
POSUFMS ; create/populate UFMS Cashiering Session
;location
K ABMP("LDFN")
S ABMLOC=$$FINDLOC^ABMUCUTL
K DIC,DIE,X,Y,DA
S DIC="^ABMUCASH("
S DIC(0)="LMN"
S (X,DINUM)="`"_ABMLOC
D ^DIC
I Y<0 Q
S ABMLOC=+Y
;
;user
K DIC,DIE,X,Y,DA
S DA(1)=ABMLOC
S DIC="^ABMUCASH(DA(1),20,"
S DIC(0)="LMN"
S DIC("P")=$P(^DD(9002274.45,".03",0),U,2)
S (X,DINUM)=1
D ^DIC
I Y<0 Q
S ABMUSER=+Y
;
;sign in date
;check for existing open session
I $D(^ABMUCASH(ABMLOC,20,1,20,0)) D
.S ABMSDT=999999999
.S ABMSFLG=0
.F S ABMSDT=$O(^ABMUCASH(ABMLOC,20,1,20,ABMSDT),-1) Q:+ABMSDT=0 D Q:ABMSFLG=1
..Q:($P($G(^ABMUCASH(ABMLOC,20,1,20,ABMSDT,0)),U,4)'="O")
..S ABMSFLG=1
I +$G(ABMSDT)=0 D
.K DIC,DIE,X,Y,DA
.S DA(2)=ABMLOC
.S DA(1)=ABMUSER
.S DIC="^ABMUCASH("_DA(2)_",20,"_DA(1)_",20,"
.S X="NOW"
.S DIC(0)="LMO"
.S DIC("P")=$P(^DD(9002274.4503,".02",0),U,2)
.S DIC("DR")=".04////O"
.D ^DIC
.Q:Y<0
.S ABMSDT=+Y
;
;insurer type
K DIC,DIE,X,Y,DA
S DA(3)=ABMLOC
S DA(2)=ABMUSER
S DA(1)=ABMSDT
S DIC="^ABMUCASH("_DA(3)_",20,"_DA(2)_",20,"_DA(1)_",11,"
;S DIC(0)="LM" ;abm*2.6*6 HEAT28427
S DIC(0)="LMX" ;abm*2.6*6 HEAT28427
S DIC("P")=$P(^DD(9002274.45302,11,0),U,2)
;S X=$P($G(^AUTNINS($P($G(^ABMDBILL(DUZ(2),ABMBILL,0)),U,8),2)),U) ;abm*2.6*10 HEAT73780
S X=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,$P($G(^ABMDBILL(DUZ(2),ABMBILL,0)),U,8),".211","I"),1,"I") ;abm*2.6*10 HEAT73780
S ABMP("INS")=$P($G(^ABMDBILL(DUZ(2),ABMBILL,0)),U,8)
D ^DIC
I +Y<0 W !,"NO ENTRY IN CASHIERING SESSION MADE",! H 2 Q
S ABMBA=+Y
;
;bill entry
K DIC,DIE,X,Y,DA
S DA(4)=ABMLOC
S DA(3)=ABMUSER
S DA(2)=ABMSDT
S DA(1)=ABMBA
S DIC="^ABMUCASH("_DA(4)_",20,"_DA(3)_",20,"_DA(2)_",11,"_DA(1)_",2,"
S X=$P($G(^ABMDBILL(DUZ(2),ABMBILL,0)),U)
S DIC(0)="LMO"
S DIC("P")=$P(^DD(9002274.4530211,".02",0),U,2)
S DIC("DR")=".02////"_DUZ(2)_";.03////"_ABMBILL
D ^DIC
Q
; *********************************************************************
CAN(ABM,ABM2) ;
; For bills that reversed through Pharmacy POS, mark them as cancelled.
; Using bill location in A/R, find it in 3PB
I '$G(ABM) Q ABM ; Don't know bill location
S ABMDUZ2=$P(ABM,",")
S ABMAR=$P(ABM,",",2)
I ('+ABMDUZ2!('+ABMAR)) Q "Not valid a/r bill location"
S ABMHOLD=DUZ(2)
S DUZ(2)=ABMDUZ2
S ABMBILL=$$GET1^DIQ(90050.01,ABMAR,.01)
I ABMBILL="" Q "No A/R Bill found" ;no A/R bill ;abm*2.6*21 IHS/SD/SDR HEAT118656
S ABMBILL=$P(ABMBILL,"-")
S DUZ(2)=$P($G(^BARBL(ABMDUZ2,ABMAR,0)),U,22) ; 3P DUZ(2)
S:DUZ(2)="" DUZ(2)=$P($G(^BARBL(ABMDUZ2,ABMAR,1)),U,8) ; visit loc
S DIC="^ABMDBILL(DUZ(2),"
S DIC(0)="XM"
S X=ABMBILL
D ^DIC
I Y'>0 D
.S DUZ(2)=$P($G(^BARBL(ABMDUZ2,ABMAR,0)),U,8) ; Parent
.D ^DIC
I Y'>0 Q "3P bill not found"
S (DA,ABMDA)=+Y
;
; Bill found, so mark as cancelled.
K DR,DIE,DIC,X,Y
S DR=".04////X"
S DIE="^ABMDBILL(DUZ(2),"
D ^DIE
I $P($G(^ABMDPARM(DUZ(2),1,4)),U,15)=1 D CPOSUFMS ;create/populate UFMS Cashiering session
Q "3P bill "_DUZ(2)_","_ABMDA_" cancelled"
CPOSUFMS ; create/populate UFMS Cashiering Session
;location
K ABMP("LDFN")
S ABMLOC=$$FINDLOC^ABMUCUTL
K DIC,DIE,X,Y,DA
S DIC="^ABMUCASH("
S DIC(0)="LMN"
S (X,DINUM)="`"_ABMLOC
D ^DIC
I Y<0 Q
S ABMLOC=+Y
;
;user
K DIC,DIE,X,Y,DA
S DA(1)=ABMLOC
S DIC="^ABMUCASH(DA(1),20,"
S DIC(0)="LMN"
S DIC("P")=$P(^DD(9002274.45,".03",0),U,2)
S (X,DINUM)=1
D ^DIC
I Y<0 Q
S ABMUSER=+Y
;
;sign in date
;check for existing open session
I $D(^ABMUCASH(ABMLOC,20,1,20,0)) D
.S ABMSDT=999999999
.S ABMSFLG=0
.F S ABMSDT=$O(^ABMUCASH(ABMLOC,20,1,20,ABMSDT),-1) Q:+ABMSDT=0 D Q:ABMSFLG=1
..Q:($P($G(^ABMUCASH(ABMLOC,20,1,20,ABMSDT,0)),U,4)'="O")
..S ABMSFLG=1
I +$G(ABMSDT)=0 D
.K DIC,DIE,X,Y,DA
.S DA(2)=ABMLOC
.S DA(1)=ABMUSER
.S DIC="^ABMUCASH("_DA(2)_",20,"_DA(1)_",20,"
.S X="NOW"
.S DIC(0)="LMO"
.S DIC("P")=$P(^DD(9002274.4503,".02",0),U,2)
.S DIC("DR")=".04////O"
.D ^DIC
.Q:Y<0
.S ABMSDT=+Y
;
;insurer type
K DIC,DIE,X,Y,DA
S DA(3)=ABMLOC
S DA(2)=ABMUSER
S DA(1)=ABMSDT
S DIC="^ABMUCASH("_DA(3)_",20,"_DA(2)_",20,"_DA(1)_",11,"
S DIC(0)="LM"
S DIC("P")=$P(^DD(9002274.45302,11,0),U,2)
;S X=$P($G(^AUTNINS($P($G(^ABMDBILL(DUZ(2),ABMDA,0)),U,8),2)),U) ;abm*2.6*10 HEAT73780
S X=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,$P($G(^ABMDBILL(DUZ(2),ABMDA,0)),U,8),".211","I"),1,"I") ;abm*2.6*10 HEAT73780
S ABMP("INS")=$P($G(^ABMDBILL(DUZ(2),ABMDA,0)),U,8)
D ^DIC
I +Y<0 W !,"NO ENTRY IN CASHIERING SESSION MADE",! H 2 Q
S ABMBA=+Y
;
;bill entry
K DIC,DIE,X,Y,DA
S DA(4)=ABMLOC
S DA(3)=ABMUSER
S DA(2)=ABMSDT
S DA(1)=ABMBA
S DIC="^ABMUCASH("_DA(4)_",20,"_DA(3)_",20,"_DA(2)_",11,"_DA(1)_",3,"
S X=$P($G(^ABMDBILL(DUZ(2),ABMDA,0)),U)
S DIC(0)="LMO"
S DIC("P")=$P(^DD(9002274.45302112,".03",0),U,2)
S DIC("DR")=".02////"_DUZ(2)_";.03////"_ABMDA
D ^DIC
Q
ABMPSAPI ; IHS/ASDS/LSL - 3PB Pharmacy POS API
+1 ;;2.6;IHS Third Party Billing System;**2,4,6,10,21**;NOV 12, 2009;Build 379
+2 ;
+3 ; IHS/ASDS/LSL - 05/17/2001 - V2.4 Patch 6 - New routine to accomodate
+4 ; Pharmacy POS. A somewhat generic API to accept info from
+5 ; Pharmacy POS to create a bill in Third Party Billing and
+6 ; therefore pass to Accounts Receivable.
+7 ; IHS/ASDS/LWJ - 06/01/2001 - V2.4 Patch 5 - altered ^DIC call for the
+8 ; insurer to no longer access the special lookup routine AUTNKWII
+9 ; IHS/ASDS/LSL - 06/14/2001 - V2.4 Patch 5 - Added CAN line tag to
+10 ; mark POS bills as cancelled when reversed through POS.
+11 ; IHS/ASDS/LSL - 07/18/01 - V2.4 Patch 8
+12 ; Resolve <DPARM>CAN+3^ABMPSAPI.
+13 ; IHS/SD/SDR - v2.5 p9 - IM15457
+14 ; Use visit location for duz(2)
+15 ; IHS/SD/SR - v2.5 p9 - IM18926
+16 ; Added capability to reprint in TPB on NCPDP format
+17 ; IHS/SD/SDR - v2.5 p10 - IM21800
+18 ; Fix for <UNDEF>DBFX+10^ABMDEFIP
+19 ; IHS/SDR/SDR - v.25 p12 - UFMS
+20 ; Changes to log POS claims for UFMS reporting/export
+21 ; IHS/SD/SDR - v2.5 p12 - IM25440
+22 ; Changed default clinic to 39 (from 25)
+23 ; IHS/SD/SDR - v2.5 p13 - IM26096
+24 ; Stop cashiering session creation for tribal sites
+25 ; and don't display warning message
+26 ; IHS/SD/SDR - abm*2.6*4 - NO HEAT - populate INSURER TYPE
+27 ; IHS/SD/SDR - abm*2.6*6 - NOHEAT - populate OTHER BILL IDENTIFER in 3P Bill file
+28 ;IHS/SD/SDR - 2.6*21 - HEAT118656 - Made change to send back error if A/R Bill isn't found (if it was deleted)
+29 ;
+30 QUIT
+31 ;
+32 ; *********************************************************************
EN(ABMPOS) ; PEP
+1 ; Pass array sub field number. ie: ARRAY(Field #)
+2 ; If field is inside a 3P Bill multiple, array needs to be
+3 ; ARRAY(Mult #,field #)
+4 ;
+5 ; ABMPOS(.21) Bill amount
+6 ; ABMPOS(.23) Gross amount
+7 ; ABMPOS(.05) Patient
+8 ; ABMPOS(.71) Service date from
+9 ; ABMPOS(.72) Service date to
+10 ; ABMPOS(.1) Clinic
+11 ; ABMPOS(.03) Visit location
+12 ; ABMPOS(.08) Active insurer
+13 ; ABMPOS(.58) Pro Authorization number
+14 ; ABMPOS(.14) Approving Official
+15 ; ABMPOS(11,.01) Visit IEN ;abm*2.6*2
+16 ; ABMPOS(41,.01) Provider multiple, Provider
+17 ; ABMPOS(23,.01) Pharmacy multiple, Medication
+18 ; ABMPOS(23,.03) Pharmacy multiple, units
+19 ; ABMPOS(23,.04) Pharmacy multiple, unit cost
+20 ; ABMPOS(23,.05) Pharmacy multiple, dispense fee
+21 ; ABMPOS(23,19) Pharmacy multiple, new/refill code
+22 ; ABMPOS(23,.06) Pharmacy multiple, Prescription
+23 ; ABMPOS(23,14) Pharmacy multiple, Date filled
+24 ; ABMPOS(23,20) Pharmacy multiple, Days supply
+25 ; ABMPOS(73,"REJDATE") POS Rejection Date ;abm*2.6*2
+26 ; ABMPOS(73,CNTR,"CODE") POS Rejection Code ;abm*2.6*2
+27 ; ABMPOS(73,CNTR,"REASON")POS Rejection Reason ;abm*2.6*2
+28 ; ABMPOS("OTHIDENT") Other Bill Identifier for A/R
+29 ;
+30 ; First determine proper DUZ(2) (code borrowed from claim generator)
+31 ; 2 assumptions: 1. Pharmacy and POS do not manipulate DUZ(2) variable
+32 ; 2. DUZ(2) is always the parent (box user is on)
+33 KILL ABMDUZ2,ABMARPS,ABMHOLD,ABMAPOK,ABMBILL,ABMFLD,ABMULT,ABMPASAR
+34 KILL DINUM,DIC,DA,DIE,X,Y,DD,DO,DLAYGO
+35 SET ABMDUZ2=ABMPOS(.03)
+36 ; Use A/R parent/sat
SET ABMARPS=$PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,9)
+37 ; Use A/R parent/sat is yes and visit location not defined under parent
+38 ; in A/R Parent/Satellite file.
+39 IF ABMARPS
IF '$DATA(^BAR(90052.05,DUZ(2),ABMPOS(.03),0))
SET ABMDUZ2=ABMPOS(.03)
+40 ; Use A/R parent/sat is yes, but DUZ(2) is not the parent for this
+41 ; visit location
+42 IF ABMARPS
IF $PIECE($GET(^BAR(90052.05,DUZ(2),ABMPOS(.03),0)),U,3)'=DUZ(2)
SET ABMDUZ2=ABMPOS(.03)
+43 IF ABMARPS
IF $PIECE($GET(^BAR(90052.05,DUZ(2),ABMPOS(.03),0)),U,6)>ABMPOS(.71)
SET ABMDUZ2=ABMPOS(.03)
+44 IF ABMARPS
IF $PIECE($GET(^BAR(90052.05,DUZ(2),ABMPOS(.03),0)),U,7)
IF $PIECE(^(0),U,7)<ABMPOS(.71)
SET ABMDUZ2=ABMPOS(.03)
+45 IF '$DATA(^ABMDPARM(ABMDUZ2,0))
QUIT "Not in 3P Parameters"
+46 ; Store DUZ(2)
SET ABMHOLD=DUZ(2)
+47 SET DUZ(2)=ABMDUZ2
+48 ;
+49 DO NOW^%DTC
+50 ; Date/Time approved = now
SET ABMPOS(.15)=%
+51 ; Bill type = outpatient
SET ABMPOS(.02)=131
+52 ; export mode NCPDP
SET ABMPOS(.06)=24
+53 ; Visit type = 901 (only POS)
SET ABMPOS(.07)=901
+54 ; Insurer multiple, priority
SET ABMPOS(13,.02)=1
+55 ; Insurer multiple, status
SET ABMPOS(13,.03)="I"
+56 ; Provider multiple, Attending
SET ABMPOS(41,.02)="A"
+57 ; always Pharmacy clinic
SET ABMPOS(.1)=39
+58 ;
+59 ; Pass 3PB to A/R
SET ABMAPOK=1
+60 KILL DINUM,DIC
+61 SET DIC(0)="LX"
+62 SET DIC="^ABMDBILL(DUZ(2),"
+63 ; Get next Claim number
SET X=$$NXNM^ABMDUTL
+64 IF 'X
SET DUZ(2)=ABMHOLD
QUIT "Next claim number unsuccessful"
+65 ; Bill number
SET X=X_"A"
+66 KILL DD,DO,DA
+67 SET DLAYGO=9002274.4
+68 DO ^DIC
+69 ; Bill addition unsuccessful
IF +Y<0
SET DUZ(2)=ABMHOLD
QUIT "3P Bill create unsuccessful"
+70 SET (DA,ABMBILL)=+Y
+71 SET DIE=DIC
+72 SET ABMFLD=0
+73 FOR
SET ABMFLD=$ORDER(ABMPOS(ABMFLD))
IF '+ABMFLD
QUIT
Begin DoDot:1
+74 IF ABMFLD>1
QUIT
+75 IF ABMPOS(ABMFLD)=""
QUIT
+76 SET DR=ABMFLD_"////"_ABMPOS(ABMFLD)
+77 DO ^DIE
End DoDot:1
+78 ;start new code abm*2.6*4 NOHEAT
+79 ;S DR=".22////"_$P($G(^AUTNINS(ABMPOS(.08),2)),U) ;abm*2.6*10 HEAT73780
+80 ;abm*2.6*10 HEAT73780
SET DR=".22////"_$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMPOS(.08),".211","I"),1,"I")
+81 DO ^DIE
+82 ;end new code abm*2.6*4 NOHEAT
+83 ;start new code abm*2.6*6 NOHEAT
+84 SET DR=".115////"_ABMPOS("OTHIDENT")
+85 DO ^DIE
+86 ;end new code abm*2.6*6 NOHEAT
+87 FOR ABMULT=13,23,41
Begin DoDot:1
+88 KILL DINUM,DIC,DA
+89 SET DA(1)=ABMBILL
+90 SET DIC("P")=$PIECE(^DD(9002274.4,ABMULT,0),U,2)
+91 SET DIC="^ABMDBILL(DUZ(2),"_DA(1)_","_ABMULT_","
+92 SET DIC(0)="LXIE"
+93 SET X=$SELECT(ABMULT=13:$PIECE(^AUTNINS(INSDFN,0),U),ABMULT=23:$PIECE(^PSDRUG(ABMPOS(23,.01),0),U),1:$PIECE(^VA(200,ABMPOS(41,.01),0),U))
+94 SET DLAYGO=9002274.4
+95 KILL DD,DO
+96 DO ^DIC
+97 ; Addition of multiple unsuccess
IF +Y<0
QUIT
+98 SET DA=+Y
+99 SET DIE=DIC
+100 SET ABMFLD=.01
+101 FOR
SET ABMFLD=$ORDER(ABMPOS(ABMULT,ABMFLD))
IF '+ABMFLD
QUIT
Begin DoDot:2
+102 IF ABMPOS(ABMULT,ABMFLD)=""
QUIT
+103 SET DR=ABMFLD_"////"_ABMPOS(ABMULT,ABMFLD)
+104 DO ^DIE
End DoDot:2
End DoDot:1
+105 ;start new code abm*2.6*2
+106 ; abm*2.6*2 this section was taken out because it stops other claims from generating.
+107 ; Visits are being merged and with this code change, it stops claims from creating that should.
+108 ; Needs to be reviewed, further tested, and included in a future patch of ABM.
+109 ;K DINUM,DIC,DA,DIE,DR,DIE
+110 ;S DA(1)=ABMBILL
+111 ;S DIC("P")=$P(^DD(9002274.4,11,0),U,2)
+112 ;S DIC="^ABMDBILL(DUZ(2),"_DA(1)_",11,"
+113 ;S DIC(0)="LE"
+114 ;S X=$G(ABMPOS(11,.01))
+115 ;S DLAYGO=9002274.4
+116 ;S DIC("DR")=".02////P"
+117 ;K DD,DO
+118 ;D FILE^DICN
+119 ;
+120 KILL DIC,DIE,DIR,X,Y,DA,DR
+121 ;rejection codes/reasons
IF $DATA(ABMPOS(73))
Begin DoDot:1
+122 SET ABMCNT=0
+123 FOR
SET ABMCNT=$ORDER(ABMPOS(73,ABMCNT))
IF (+$GET(ABMCNT)=0)
QUIT
Begin DoDot:2
+124 KILL DIC,DIE,DIR,DA,DR,X,Y
+125 SET DA(1)=ABMBILL
+126 SET DIC="^ABMDBILL(DUZ(2),"_DA(1)_",73,"
+127 SET DIC(0)="LE"
+128 SET DIC("P")=$PIECE(^DD(9002274.4,73,0),U,2)
+129 SET X=$GET(ABMPOS(73,ABMCNT,"CODE"))
+130 SET DIC("DR")=".02////"_$GET(ABMPOS(73,ABMCNT,"REASON"))_";.03////"_$GET(ABMPOS(73,"REJDATE"))
+131 KILL DD,DO
+132 DO ^DIC
End DoDot:2
End DoDot:1
+133 ;end new code abm*2.6*2
+134 ; This DIE call needs to be done last. It's the x-ref on this field
+135 ; that creates the bill in A/R from 3PB. It also defines the A/R
+136 ; location field on the 3P bill [DUZ(2),DA].
+137 KILL DIE,DA,DR
+138 SET DIE="^ABMDBILL(DUZ(2),"
+139 SET DA=ABMBILL
+140 ; Set bill status to B
SET DR=".04////B"
+141 DO ^DIE
+142 SET ABMPASAR=$PIECE($GET(^ABMDBILL(DUZ(2),ABMBILL,2)),U,6)
+143 ;create/populate UFMS Cashiering session
IF $PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,15)=1
DO POSUFMS
+144 ; Restore DUZ(2)
SET DUZ(2)=ABMHOLD
+145 KILL ABMDUZ2,ABMARPS,ABMHOLD,ABMAPOK,ABMBILL,ABMFLD,ABMULT,ABMPOS
+146 KILL DINUM,DIC,DA,DIE,X,Y,DD,DO,DLAYGO
+147 IF ABMPASAR=""
QUIT "A/R Bill population unsuccessful"
+148 ; A/R DUZ(2),IEN
QUIT ABMPASAR
+149 ;
+150 ; *********************************************************************
POSUFMS ; create/populate UFMS Cashiering Session
+1 ;location
+2 KILL ABMP("LDFN")
+3 SET ABMLOC=$$FINDLOC^ABMUCUTL
+4 KILL DIC,DIE,X,Y,DA
+5 SET DIC="^ABMUCASH("
+6 SET DIC(0)="LMN"
+7 SET (X,DINUM)="`"_ABMLOC
+8 DO ^DIC
+9 IF Y<0
QUIT
+10 SET ABMLOC=+Y
+11 ;
+12 ;user
+13 KILL DIC,DIE,X,Y,DA
+14 SET DA(1)=ABMLOC
+15 SET DIC="^ABMUCASH(DA(1),20,"
+16 SET DIC(0)="LMN"
+17 SET DIC("P")=$PIECE(^DD(9002274.45,".03",0),U,2)
+18 SET (X,DINUM)=1
+19 DO ^DIC
+20 IF Y<0
QUIT
+21 SET ABMUSER=+Y
+22 ;
+23 ;sign in date
+24 ;check for existing open session
+25 IF $DATA(^ABMUCASH(ABMLOC,20,1,20,0))
Begin DoDot:1
+26 SET ABMSDT=999999999
+27 SET ABMSFLG=0
+28 FOR
SET ABMSDT=$ORDER(^ABMUCASH(ABMLOC,20,1,20,ABMSDT),-1)
IF +ABMSDT=0
QUIT
Begin DoDot:2
+29 IF ($PIECE($GET(^ABMUCASH(ABMLOC,20,1,20,ABMSDT,0)),U,4)'="O")
QUIT
+30 SET ABMSFLG=1
End DoDot:2
IF ABMSFLG=1
QUIT
End DoDot:1
+31 IF +$GET(ABMSDT)=0
Begin DoDot:1
+32 KILL DIC,DIE,X,Y,DA
+33 SET DA(2)=ABMLOC
+34 SET DA(1)=ABMUSER
+35 SET DIC="^ABMUCASH("_DA(2)_",20,"_DA(1)_",20,"
+36 SET X="NOW"
+37 SET DIC(0)="LMO"
+38 SET DIC("P")=$PIECE(^DD(9002274.4503,".02",0),U,2)
+39 SET DIC("DR")=".04////O"
+40 DO ^DIC
+41 IF Y<0
QUIT
+42 SET ABMSDT=+Y
End DoDot:1
+43 ;
+44 ;insurer type
+45 KILL DIC,DIE,X,Y,DA
+46 SET DA(3)=ABMLOC
+47 SET DA(2)=ABMUSER
+48 SET DA(1)=ABMSDT
+49 SET DIC="^ABMUCASH("_DA(3)_",20,"_DA(2)_",20,"_DA(1)_",11,"
+50 ;S DIC(0)="LM" ;abm*2.6*6 HEAT28427
+51 ;abm*2.6*6 HEAT28427
SET DIC(0)="LMX"
+52 SET DIC("P")=$PIECE(^DD(9002274.45302,11,0),U,2)
+53 ;S X=$P($G(^AUTNINS($P($G(^ABMDBILL(DUZ(2),ABMBILL,0)),U,8),2)),U) ;abm*2.6*10 HEAT73780
+54 ;abm*2.6*10 HEAT73780
SET X=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,$PIECE($GET(^ABMDBILL(DUZ(2),ABMBILL,0)),U,8),".211","I"),1,"I")
+55 SET ABMP("INS")=$PIECE($GET(^ABMDBILL(DUZ(2),ABMBILL,0)),U,8)
+56 DO ^DIC
+57 IF +Y<0
WRITE !,"NO ENTRY IN CASHIERING SESSION MADE",!
HANG 2
QUIT
+58 SET ABMBA=+Y
+59 ;
+60 ;bill entry
+61 KILL DIC,DIE,X,Y,DA
+62 SET DA(4)=ABMLOC
+63 SET DA(3)=ABMUSER
+64 SET DA(2)=ABMSDT
+65 SET DA(1)=ABMBA
+66 SET DIC="^ABMUCASH("_DA(4)_",20,"_DA(3)_",20,"_DA(2)_",11,"_DA(1)_",2,"
+67 SET X=$PIECE($GET(^ABMDBILL(DUZ(2),ABMBILL,0)),U)
+68 SET DIC(0)="LMO"
+69 SET DIC("P")=$PIECE(^DD(9002274.4530211,".02",0),U,2)
+70 SET DIC("DR")=".02////"_DUZ(2)_";.03////"_ABMBILL
+71 DO ^DIC
+72 QUIT
+73 ; *********************************************************************
CAN(ABM,ABM2) ;
+1 ; For bills that reversed through Pharmacy POS, mark them as cancelled.
+2 ; Using bill location in A/R, find it in 3PB
+3 ; Don't know bill location
IF '$GET(ABM)
QUIT ABM
+4 SET ABMDUZ2=$PIECE(ABM,",")
+5 SET ABMAR=$PIECE(ABM,",",2)
+6 IF ('+ABMDUZ2!('+ABMAR))
QUIT "Not valid a/r bill location"
+7 SET ABMHOLD=DUZ(2)
+8 SET DUZ(2)=ABMDUZ2
+9 SET ABMBILL=$$GET1^DIQ(90050.01,ABMAR,.01)
+10 ;no A/R bill ;abm*2.6*21 IHS/SD/SDR HEAT118656
IF ABMBILL=""
QUIT "No A/R Bill found"
+11 SET ABMBILL=$PIECE(ABMBILL,"-")
+12 ; 3P DUZ(2)
SET DUZ(2)=$PIECE($GET(^BARBL(ABMDUZ2,ABMAR,0)),U,22)
+13 ; visit loc
IF DUZ(2)=""
SET DUZ(2)=$PIECE($GET(^BARBL(ABMDUZ2,ABMAR,1)),U,8)
+14 SET DIC="^ABMDBILL(DUZ(2),"
+15 SET DIC(0)="XM"
+16 SET X=ABMBILL
+17 DO ^DIC
+18 IF Y'>0
Begin DoDot:1
+19 ; Parent
SET DUZ(2)=$PIECE($GET(^BARBL(ABMDUZ2,ABMAR,0)),U,8)
+20 DO ^DIC
End DoDot:1
+21 IF Y'>0
QUIT "3P bill not found"
+22 SET (DA,ABMDA)=+Y
+23 ;
+24 ; Bill found, so mark as cancelled.
+25 KILL DR,DIE,DIC,X,Y
+26 SET DR=".04////X"
+27 SET DIE="^ABMDBILL(DUZ(2),"
+28 DO ^DIE
+29 ;create/populate UFMS Cashiering session
IF $PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,15)=1
DO CPOSUFMS
+30 QUIT "3P bill "_DUZ(2)_","_ABMDA_" cancelled"
CPOSUFMS ; create/populate UFMS Cashiering Session
+1 ;location
+2 KILL ABMP("LDFN")
+3 SET ABMLOC=$$FINDLOC^ABMUCUTL
+4 KILL DIC,DIE,X,Y,DA
+5 SET DIC="^ABMUCASH("
+6 SET DIC(0)="LMN"
+7 SET (X,DINUM)="`"_ABMLOC
+8 DO ^DIC
+9 IF Y<0
QUIT
+10 SET ABMLOC=+Y
+11 ;
+12 ;user
+13 KILL DIC,DIE,X,Y,DA
+14 SET DA(1)=ABMLOC
+15 SET DIC="^ABMUCASH(DA(1),20,"
+16 SET DIC(0)="LMN"
+17 SET DIC("P")=$PIECE(^DD(9002274.45,".03",0),U,2)
+18 SET (X,DINUM)=1
+19 DO ^DIC
+20 IF Y<0
QUIT
+21 SET ABMUSER=+Y
+22 ;
+23 ;sign in date
+24 ;check for existing open session
+25 IF $DATA(^ABMUCASH(ABMLOC,20,1,20,0))
Begin DoDot:1
+26 SET ABMSDT=999999999
+27 SET ABMSFLG=0
+28 FOR
SET ABMSDT=$ORDER(^ABMUCASH(ABMLOC,20,1,20,ABMSDT),-1)
IF +ABMSDT=0
QUIT
Begin DoDot:2
+29 IF ($PIECE($GET(^ABMUCASH(ABMLOC,20,1,20,ABMSDT,0)),U,4)'="O")
QUIT
+30 SET ABMSFLG=1
End DoDot:2
IF ABMSFLG=1
QUIT
End DoDot:1
+31 IF +$GET(ABMSDT)=0
Begin DoDot:1
+32 KILL DIC,DIE,X,Y,DA
+33 SET DA(2)=ABMLOC
+34 SET DA(1)=ABMUSER
+35 SET DIC="^ABMUCASH("_DA(2)_",20,"_DA(1)_",20,"
+36 SET X="NOW"
+37 SET DIC(0)="LMO"
+38 SET DIC("P")=$PIECE(^DD(9002274.4503,".02",0),U,2)
+39 SET DIC("DR")=".04////O"
+40 DO ^DIC
+41 IF Y<0
QUIT
+42 SET ABMSDT=+Y
End DoDot:1
+43 ;
+44 ;insurer type
+45 KILL DIC,DIE,X,Y,DA
+46 SET DA(3)=ABMLOC
+47 SET DA(2)=ABMUSER
+48 SET DA(1)=ABMSDT
+49 SET DIC="^ABMUCASH("_DA(3)_",20,"_DA(2)_",20,"_DA(1)_",11,"
+50 SET DIC(0)="LM"
+51 SET DIC("P")=$PIECE(^DD(9002274.45302,11,0),U,2)
+52 ;S X=$P($G(^AUTNINS($P($G(^ABMDBILL(DUZ(2),ABMDA,0)),U,8),2)),U) ;abm*2.6*10 HEAT73780
+53 ;abm*2.6*10 HEAT73780
SET X=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,$PIECE($GET(^ABMDBILL(DUZ(2),ABMDA,0)),U,8),".211","I"),1,"I")
+54 SET ABMP("INS")=$PIECE($GET(^ABMDBILL(DUZ(2),ABMDA,0)),U,8)
+55 DO ^DIC
+56 IF +Y<0
WRITE !,"NO ENTRY IN CASHIERING SESSION MADE",!
HANG 2
QUIT
+57 SET ABMBA=+Y
+58 ;
+59 ;bill entry
+60 KILL DIC,DIE,X,Y,DA
+61 SET DA(4)=ABMLOC
+62 SET DA(3)=ABMUSER
+63 SET DA(2)=ABMSDT
+64 SET DA(1)=ABMBA
+65 SET DIC="^ABMUCASH("_DA(4)_",20,"_DA(3)_",20,"_DA(2)_",11,"_DA(1)_",3,"
+66 SET X=$PIECE($GET(^ABMDBILL(DUZ(2),ABMDA,0)),U)
+67 SET DIC(0)="LMO"
+68 SET DIC("P")=$PIECE(^DD(9002274.45302112,".03",0),U,2)
+69 SET DIC("DR")=".02////"_DUZ(2)_";.03////"_ABMDA
+70 DO ^DIC
+71 QUIT
