ABMELGCK ; IHS/SD/SDR - Recreate cancelled claim from PCC ;
;;2.6;IHS 3P BILLING SYSTEM;**14,21**;NOV 12, 2009;Build 379
;Allows user to look up eligibility for visit by patient
;This runs "eligiblity checker" portion of CG and outputs
;ABML array of info found
;IHS/SD/SDR - 2.6*21 - HEAT123571 - defined ABMP("VDT") to stop <UNDEF>OPCK+13^ABMDVCK1 error
;IHS/SD/SDR - 2.6*21 - HEAT137034 - Added visit type to display
;
START ;EP
S DIC="^AUPNPAT("
S DIC(0)="AEMQ"
S DIC("S")="I $D(^AUPNVSIT(""AC"",Y))"
D ^DIC
I Y<0 G Q
S ABMPDFN=+Y
S DIC="^AUPNVSIT("
S DIC(0)="AEQ"
S DIC("S")="I $D(^AUPNVSIT(""AC"",DFN,Y))&'$P(^AUPNVSIT(Y,0),U,11)"
D ^DIC
I Y<0 G Q
S ABMVDFN=+Y
;S ABMVDT=+$P($G(^AUPNVSIT(ABMVDFN,0)),U) ;abm*2.6*21 IHS/SD/SDR HEAT123571
S (ABMVDT,ABMP("VDT"))=+$P($G(^AUPNVSIT(ABMVDFN,0)),U) ;abm*2.6*21 IHS/SD/SDR HEAT123571
S ABMSERVC=$P($G(^AUPNVSIT(ABMVDFN,0)),U,7) ;abm*2.6*21 IHS/SD/SDR HEAT137034
S ABMCLN=$$GET1^DIQ(40.7,$P($G(^AUPNVSIT(ABMVDFN,0)),U,8),1,"E") ;abm*2.6*21 IHS/SD/SDR HEAT137034
S ABML=""
D ELG^ABMDLCK(ABMVDFN,.ABML,ABMPDFN,ABMVDT)
;
W !!
W !,"For patient ",$P($G(^DPT(ABMPDFN,0)),U),", for visit ",$$CDT^ABMDUTL($P($G(^AUPNVSIT(ABMVDFN,0)),U)),!
;W "PRIORITY",?9,"INSURER",?37,"STATUS",?50,"REASON UNBILLABLE",! ;abm*2.6*21 IHS/SD/SDR HEAT137034
W "PRIORITY",?9,"INSURER",?37,"VTYP",?42,"STATUS",?53,"REASON UNBILLABLE",! ;abm*2.6*21 IHS/SD/SDR HEAT137034
F A=1:1:80 W "-"
W !
S ABMPRI=0
K ABME
F S ABMPRI=$O(ABML(ABMPRI)) Q:+ABMPRI=0 D
.S ABMINS=0
.F S ABMINS=$O(ABML(ABMPRI,ABMINS)) Q:+ABMINS=0 D
..W ?2,ABMPRI
..W ?9,$E($P($G(^AUTNINS(ABMINS,0)),U),1,20)_"("_ABMINS_")"
..W ?37,$$VTYP^ABMDVCK1(ABMVDFN,ABMSERVC,ABMINS,ABMCLN) ;abm*2.6*21 IHS/SD/SDR HEAT137034
..;W ?37,$S(+$P(ABML(ABMPRI,ABMINS),U,6):"UNBILLABLE",1:"BILLABLE") ;abm*2.6*21 IHS/SD/SDR HEAT137034
..W ?42,$S(+$P(ABML(ABMPRI,ABMINS),U,6):"UNBILLABLE",1:"BILLABLE") ;abm*2.6*21 IHS/SD/SDR HEAT137034
..;W:$P(ABML(ABMPRI,ABMINS),U,6) ?50,"("_$P(ABML(ABMPRI,ABMINS),U,6)_")",$E($P($G(^ABMDCS($P(ABML(ABMPRI,ABMINS),U,6),0)),U),1,26) ;abm*2.6*21 IHS/SD/SDR HEAT137034
..W:$P(ABML(ABMPRI,ABMINS),U,6) ?53,"("_$P(ABML(ABMPRI,ABMINS),U,6)_")",$E($P($G(^ABMDCS($P(ABML(ABMPRI,ABMINS),U,6),0)),U),1,23) ;abm*2.6*21 IHS/SD/SDR HEAT137034
..W !
..Q:($P(ABML(ABMPRI,ABMINS),U,6)="")
..S ABME($P(ABML(ABMPRI,ABMINS),U,6))=""
W !!
I $D(ABME) D
.W ?1,"REASON UNBILLABLE KEY:"
.S ABMA=0
.F S ABMA=$O(ABME(ABMA)) Q:+ABMA=0 D
..W !?3,ABMA_" - ",$P($G(^ABMDCS(ABMA,0)),U)
.W !
G START
;
Q K DIC,DIE,ABMV,DR
Q
ABMELGCK ; IHS/SD/SDR - Recreate cancelled claim from PCC ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**14,21**;NOV 12, 2009;Build 379
+2 ;Allows user to look up eligibility for visit by patient
+3 ;This runs "eligiblity checker" portion of CG and outputs
+4 ;ABML array of info found
+5 ;IHS/SD/SDR - 2.6*21 - HEAT123571 - defined ABMP("VDT") to stop <UNDEF>OPCK+13^ABMDVCK1 error
+6 ;IHS/SD/SDR - 2.6*21 - HEAT137034 - Added visit type to display
+7 ;
START ;EP
+1 SET DIC="^AUPNPAT("
+2 SET DIC(0)="AEMQ"
+3 SET DIC("S")="I $D(^AUPNVSIT(""AC"",Y))"
+4 DO ^DIC
+5 IF Y<0
GOTO Q
+6 SET ABMPDFN=+Y
+7 SET DIC="^AUPNVSIT("
+8 SET DIC(0)="AEQ"
+9 SET DIC("S")="I $D(^AUPNVSIT(""AC"",DFN,Y))&'$P(^AUPNVSIT(Y,0),U,11)"
+10 DO ^DIC
+11 IF Y<0
GOTO Q
+12 SET ABMVDFN=+Y
+13 ;S ABMVDT=+$P($G(^AUPNVSIT(ABMVDFN,0)),U) ;abm*2.6*21 IHS/SD/SDR HEAT123571
+14 ;abm*2.6*21 IHS/SD/SDR HEAT123571
SET (ABMVDT,ABMP("VDT"))=+$PIECE($GET(^AUPNVSIT(ABMVDFN,0)),U)
+15 ;abm*2.6*21 IHS/SD/SDR HEAT137034
SET ABMSERVC=$PIECE($GET(^AUPNVSIT(ABMVDFN,0)),U,7)
+16 ;abm*2.6*21 IHS/SD/SDR HEAT137034
SET ABMCLN=$$GET1^DIQ(40.7,$PIECE($GET(^AUPNVSIT(ABMVDFN,0)),U,8),1,"E")
+17 SET ABML=""
+18 DO ELG^ABMDLCK(ABMVDFN,.ABML,ABMPDFN,ABMVDT)
+19 ;
+20 WRITE !!
+21 WRITE !,"For patient ",$PIECE($GET(^DPT(ABMPDFN,0)),U),", for visit ",$$CDT^ABMDUTL($PIECE($GET(^AUPNVSIT(ABMVDFN,0)),U)),!
+22 ;W "PRIORITY",?9,"INSURER",?37,"STATUS",?50,"REASON UNBILLABLE",! ;abm*2.6*21 IHS/SD/SDR HEAT137034
+23 ;abm*2.6*21 IHS/SD/SDR HEAT137034
WRITE "PRIORITY",?9,"INSURER",?37,"VTYP",?42,"STATUS",?53,"REASON UNBILLABLE",!
+24 FOR A=1:1:80
WRITE "-"
+25 WRITE !
+26 SET ABMPRI=0
+27 KILL ABME
+28 FOR
SET ABMPRI=$ORDER(ABML(ABMPRI))
IF +ABMPRI=0
QUIT
Begin DoDot:1
+29 SET ABMINS=0
+30 FOR
SET ABMINS=$ORDER(ABML(ABMPRI,ABMINS))
IF +ABMINS=0
QUIT
Begin DoDot:2
+31 WRITE ?2,ABMPRI
+32 WRITE ?9,$EXTRACT($PIECE($GET(^AUTNINS(ABMINS,0)),U),1,20)_"("_ABMINS_")"
+33 ;abm*2.6*21 IHS/SD/SDR HEAT137034
WRITE ?37,$$VTYP^ABMDVCK1(ABMVDFN,ABMSERVC,ABMINS,ABMCLN)
+34 ;W ?37,$S(+$P(ABML(ABMPRI,ABMINS),U,6):"UNBILLABLE",1:"BILLABLE") ;abm*2.6*21 IHS/SD/SDR HEAT137034
+35 ;abm*2.6*21 IHS/SD/SDR HEAT137034
WRITE ?42,$SELECT(+$PIECE(ABML(ABMPRI,ABMINS),U,6):"UNBILLABLE",1:"BILLABLE")
+36 ;W:$P(ABML(ABMPRI,ABMINS),U,6) ?50,"("_$P(ABML(ABMPRI,ABMINS),U,6)_")",$E($P($G(^ABMDCS($P(ABML(ABMPRI,ABMINS),U,6),0)),U),1,26) ;abm*2.6*21 IHS/SD/SDR HEAT137034
+37 ;abm*2.6*21 IHS/SD/SDR HEAT137034
IF $PIECE(ABML(ABMPRI,ABMINS),U,6)
WRITE ?53,"("_$PIECE(ABML(ABMPRI,ABMINS),U,6)_")",$EXTRACT($PIECE($GET(^ABMDCS($PIECE(ABML(ABMPRI,ABMINS),U,6),0)),U),1,23)
+38 WRITE !
+39 IF ($PIECE(ABML(ABMPRI,ABMINS),U,6)="")
QUIT
+40 SET ABME($PIECE(ABML(ABMPRI,ABMINS),U,6))=""
End DoDot:2
End DoDot:1
+41 WRITE !!
+42 IF $DATA(ABME)
Begin DoDot:1
+43 WRITE ?1,"REASON UNBILLABLE KEY:"
+44 SET ABMA=0
+45 FOR
SET ABMA=$ORDER(ABME(ABMA))
IF +ABMA=0
QUIT
Begin DoDot:2
+46 WRITE !?3,ABMA_" - ",$PIECE($GET(^ABMDCS(ABMA,0)),U)
End DoDot:2
+47 WRITE !
End DoDot:1
+48 GOTO START
+49 ;
Q KILL DIC,DIE,ABMV,DR
+1 QUIT
