PXBIBB ;ALB/DWS/BDB - SEND CHARGE OR CREDIT TRANSACTIONS TO IBB ;8/10/05 1:29pm
;;1.0;PCE PATIENT CARE ENCOUNTER;**164**;Aug 12, 1996
N VSTB,PKB,VSTA,PKA,PRVB,PRVA,SC,IBBAPLR,IBBDFN
N IBBARFN,IBBUCID,CD,CD12,CDA,CDB,CDI,DX,IO,MOD
N IBBCTYPE,IBBORIEN,ND,TYPE,VDT,PPRV,SPRV,APRV,OPRV,ORY
S VSTA=$G(^TMP("PXKCO",$J,PXKVVST,"VST",PXKVVST,0,"AFTER"))
S PKA=$G(^TMP("PXKCO",$J,PXKVVST,"VST",PXKVVST,812,"AFTER"))
S IO=$P($G(^TMP("PXKCO",$J,PXKVVST,"VST",PXKVVST,150,"AFTER")),U,2)
S VSTB=$G(^TMP("PXKCO",$J,PXKVVST,"VST",PXKVVST,0,"BEFORE"))
S PKB=$G(^TMP("PXKCO",$J,PXKVVST,"VST",PXKVVST,812,"BEFORE"))
S:IO="" IO=$P($G(^TMP("PXKCO",$J,PXKVVST,"VST",PXKVVST,150,"BEFORE")),U,2)
Q:$P(VSTB,U,7)="E" Q:$P(VSTA,U,7)="E"
Q:$P(PKB,U,2)=$$PKG2IEN^VSIT("RMPR") Q:$P(PKA,U,2)=$$PKG2IEN^VSIT("RMPR")
S SC=$O(^SCE("AVSIT",PXKVVST,0))
S:'SC SC=$O(^TMP("PXKCO",$J,PXKVVST,"OE",0)) D:'SC Q:'SC
.Q:'IO
.S CDI=0 F S CDI=$O(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI)) Q:CDI="" D
..S CDB=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,0,"BEFORE"))
..I $P(CDB,U)'="" S CD=CDB,CD12=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,12,"BEFORE")) D CHG("BEFORE")
..S CDA=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,0,"AFTER"))
..I $P(CDA,U)'="" S CD=CDA,CD12=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,12,"AFTER")) D CHG("AFTER")
S BSTATUS=$P($G(^TMP("PXKCO",$J,PXKVVST,"OE",SC,0,"BEFORE")),U,7)
I '$P($G(^SCE(SC,0)),U,7) Q:'BSTATUS D Q
.S CDI=0 F S CDI=$O(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI)) Q:CDI="" D
..S CD=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,0,"BEFORE"))
..S CD12=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,12,"BEFORE"))
..D CHG("BEFORE")
S CDI=0 F S CDI=$O(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI)) Q:CDI="" D
.S:BSTATUS CDB=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,0,"BEFORE"))
.S CDA=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,0,"AFTER"))
.I BSTATUS,$P(CDA,U)="" D D CHG("BEFORE") Q
..S CD=CDB,CD12=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,12,"BEFORE"))
.S CD=CDA,CD12=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,12,"AFTER"))
.D CHG("AFTER")
Q
CHG(TYPE) ;PROCESS DEBITS OR CREDITS, BEFORE = CREDIT, AFTER = DEBIT
N IBBFT1,IBBPR1,IBBDG1,IBBZCL,DXS,FDX,I
D LD($S(VSTA:VSTA,1:VSTB))
S IBBUCID=$P(CD,U,20),IBBORIEN=$P(CD,U,17),IBBFT1(2)="PX"_PXKVVST,IBBFT1(20)=$P(CD12,U,4),IBBFT1(21)=$P(CD12,U,2) ;PRFM,ORDR - CPT ENC,ORD
I 'IBBUCID S IBBUCID=$$GETCHGID^IBBAPI(),DA=CDI,DR=".2///"_IBBUCID D
.S DIE="^AUPNVCPT(" D ^DIE
S I="" F S I=$O(^TMP("PXKCO",$J,PXKVVST,"PRV",I)) Q:I="" D
.S PRV=$G(^TMP("PXKCO",$J,PXKVVST,"PRV",I,0,TYPE))
.I $P(PRV,U,4)="P" S PPRV=+PRV
.I $P(PRV,U,4)="S" S SPRV=+PRV
.I $P(PRV,U,5)="A" S APRV=+PRV
.I $P(PRV,U,5)="O" S OPRV=+PRV
I IBBFT1(20)="" S IBBFT1(20)=$G(PPRV) ;PRFM - NULL, THEN PRV PRIMARY
S IBBCTYPE=$S(TYPE="BEFORE":"CD",1:"CG"),IBBFT1(10)=$P(CD,U,16)
S (IBBFT1(13),I)=$S($P(CD,U,19)]"":$P(CD,U,19),1:999),IBBFT1(4)=$S(CD12:+CD12,1:VDT)
S IBBPR1(3)=+CD,IBBPR1(5)=IBBFT1(4)
I "180^401^402^403^404^406^407^409^410^411^412^413^415^457"[I D
.S IBBPR1(11,1)=$G(OPRV) I IBBPR1(11,1)="" S IBBPR1(11,1)=IBBFT1(20)
.S IBBPR1(11,2)=$G(APRV)
N IBBARFNZ I $E($T(ORACTREF^ORWPFSS),9)="(",I=108,IBBORIEN D ORACTREF^ORWPFSS(.IBBARFNZ,.IBBORIEN) I IBBARFNZ]"" S IBBARFN=IBBARFNZ
S MOD="",I=0
F S I=$O(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,1,TYPE,I)) Q:I="" S MOD=$S(MOD="":I,1:MOD_";"_I)
S I=0 F S I=$O(^TMP("PXKCO",$J,PXKVVST,"POV",I)) Q:I="" D
.S DXS=$G(^(I,0,TYPE))
.S DXS(+DXS)=$G(^TMP("PXKCO",$J,PXKVVST,"POV",I,800,TYPE))
S IBBPR1(16)=MOD
F I=1:1:8 S SC(I)="" ;SHAD
S FDX=1 F I=5,9:1:15 S DX=$P(CD,U,I) I DX S J=$S(I=5:1,1:I-7) D S FDX=0
.S IBBDG1(J,3)=DX,IBBDG1(J,6)="F",DXS=$G(DXS(DX))
.F J=1:1:8 I 'SC(J) D ;SHAD
..I $P($G(DXS(DX)),U,J) S SC(J)=1 Q
..I $P($G(DXS(DX)),U,J)="" S SC(J)="" Q
..I $P($G(DXS(DX)),U,J)=0,FDX=1 S SC(J)=0
S SC=$G(^TMP("PXKCO",$J,PXKVVST,"VST",PXKVVST,800,TYPE))
F I=1:1:8 I SC(I)="" S SC(I)=$P(SC,U,I) ;SHAD
F I=1:1:8 S J=$S(I=1:3,I=2:1,I=3:2,1:I),IBBZCL(J,2)=J,IBBZCL(J,3)=SC(I) ;SHAD
I IBBZCL(3,3) F I=1,2,4 S IBBZCL(I,3)=""
W $$CHARGE^IBBAPI(IBBDFN,IBBARFN,IBBCTYPE,IBBUCID,.IBBFT1,.IBBPR1,.IBBDG1,.IBBZCL,.IBBRXE,IBBORIEN,.IBBPROS)
Q
LD(ND) S IBBDFN=$P(ND,U,5),IBBARFN=$P(ND,U,26),VDT=+ND
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBIBB 4215 printed Dec 13, 2024@02:26:58 Page 2
PXBIBB ;ALB/DWS/BDB - SEND CHARGE OR CREDIT TRANSACTIONS TO IBB ;8/10/05 1:29pm
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**164**;Aug 12, 1996
+2 NEW VSTB,PKB,VSTA,PKA,PRVB,PRVA,SC,IBBAPLR,IBBDFN
+3 NEW IBBARFN,IBBUCID,CD,CD12,CDA,CDB,CDI,DX,IO,MOD
+4 NEW IBBCTYPE,IBBORIEN,ND,TYPE,VDT,PPRV,SPRV,APRV,OPRV,ORY
+5 SET VSTA=$GET(^TMP("PXKCO",$JOB,PXKVVST,"VST",PXKVVST,0,"AFTER"))
+6 SET PKA=$GET(^TMP("PXKCO",$JOB,PXKVVST,"VST",PXKVVST,812,"AFTER"))
+7 SET IO=$PIECE($GET(^TMP("PXKCO",$JOB,PXKVVST,"VST",PXKVVST,150,"AFTER")),U,2)
+8 SET VSTB=$GET(^TMP("PXKCO",$JOB,PXKVVST,"VST",PXKVVST,0,"BEFORE"))
+9 SET PKB=$GET(^TMP("PXKCO",$JOB,PXKVVST,"VST",PXKVVST,812,"BEFORE"))
+10 if IO=""
SET IO=$PIECE($GET(^TMP("PXKCO",$JOB,PXKVVST,"VST",PXKVVST,150,"BEFORE")),U,2)
+11 if $PIECE(VSTB,U,7)="E"
QUIT
if $PIECE(VSTA,U,7)="E"
QUIT
+12 if $PIECE(PKB,U,2)=$$PKG2IEN^VSIT("RMPR")
QUIT
if $PIECE(PKA,U,2)=$$PKG2IEN^VSIT("RMPR")
QUIT
+13 SET SC=$ORDER(^SCE("AVSIT",PXKVVST,0))
+14 if 'SC
SET SC=$ORDER(^TMP("PXKCO",$JOB,PXKVVST,"OE",0))
if 'SC
Begin DoDot:1
+15 if 'IO
QUIT
+16 SET CDI=0
FOR
SET CDI=$ORDER(^TMP("PXKCO",$JOB,PXKVVST,"CPT",CDI))
if CDI=""
QUIT
Begin DoDot:2
+17 SET CDB=$GET(^TMP("PXKCO",$JOB,PXKVVST,"CPT",CDI,0,"BEFORE"))
+18 IF $PIECE(CDB,U)'=""
SET CD=CDB
SET CD12=$GET(^TMP("PXKCO",$JOB,PXKVVST,"CPT",CDI,12,"BEFORE"))
DO CHG("BEFORE")
+19 SET CDA=$GET(^TMP("PXKCO",$JOB,PXKVVST,"CPT",CDI,0,"AFTER"))
+20 IF $PIECE(CDA,U)'=""
SET CD=CDA
SET CD12=$GET(^TMP("PXKCO",$JOB,PXKVVST,"CPT",CDI,12,"AFTER"))
DO CHG("AFTER")
End DoDot:2
End DoDot:1
if 'SC
QUIT
+21 SET BSTATUS=$PIECE($GET(^TMP("PXKCO",$JOB,PXKVVST,"OE",SC,0,"BEFORE")),U,7)
+22 IF '$PIECE($GET(^SCE(SC,0)),U,7)
if 'BSTATUS
QUIT
Begin DoDot:1
+23 SET CDI=0
FOR
SET CDI=$ORDER(^TMP("PXKCO",$JOB,PXKVVST,"CPT",CDI))
if CDI=""
QUIT
Begin DoDot:2
+24 SET CD=$GET(^TMP("PXKCO",$JOB,PXKVVST,"CPT",CDI,0,"BEFORE"))
+25 SET CD12=$GET(^TMP("PXKCO",$JOB,PXKVVST,"CPT",CDI,12,"BEFORE"))
+26 DO CHG("BEFORE")
End DoDot:2
End DoDot:1
QUIT
+27 SET CDI=0
FOR
SET CDI=$ORDER(^TMP("PXKCO",$JOB,PXKVVST,"CPT",CDI))
if CDI=""
QUIT
Begin DoDot:1
+28 if BSTATUS
SET CDB=$GET(^TMP("PXKCO",$JOB,PXKVVST,"CPT",CDI,0,"BEFORE"))
+29 SET CDA=$GET(^TMP("PXKCO",$JOB,PXKVVST,"CPT",CDI,0,"AFTER"))
+30 IF BSTATUS
IF $PIECE(CDA,U)=""
Begin DoDot:2
+31 SET CD=CDB
SET CD12=$GET(^TMP("PXKCO",$JOB,PXKVVST,"CPT",CDI,12,"BEFORE"))
End DoDot:2
DO CHG("BEFORE")
QUIT
+32 SET CD=CDA
SET CD12=$GET(^TMP("PXKCO",$JOB,PXKVVST,"CPT",CDI,12,"AFTER"))
+33 DO CHG("AFTER")
End DoDot:1
+34 QUIT
CHG(TYPE) ;PROCESS DEBITS OR CREDITS, BEFORE = CREDIT, AFTER = DEBIT
+1 NEW IBBFT1,IBBPR1,IBBDG1,IBBZCL,DXS,FDX,I
+2 DO LD($SELECT(VSTA:VSTA,1:VSTB))
+3 ;PRFM,ORDR - CPT ENC,ORD
SET IBBUCID=$PIECE(CD,U,20)
SET IBBORIEN=$PIECE(CD,U,17)
SET IBBFT1(2)="PX"_PXKVVST
SET IBBFT1(20)=$PIECE(CD12,U,4)
SET IBBFT1(21)=$PIECE(CD12,U,2)
+4 IF 'IBBUCID
SET IBBUCID=$$GETCHGID^IBBAPI()
SET DA=CDI
SET DR=".2///"_IBBUCID
Begin DoDot:1
+5 SET DIE="^AUPNVCPT("
DO ^DIE
End DoDot:1
+6 SET I=""
FOR
SET I=$ORDER(^TMP("PXKCO",$JOB,PXKVVST,"PRV",I))
if I=""
QUIT
Begin DoDot:1
+7 SET PRV=$GET(^TMP("PXKCO",$JOB,PXKVVST,"PRV",I,0,TYPE))
+8 IF $PIECE(PRV,U,4)="P"
SET PPRV=+PRV
+9 IF $PIECE(PRV,U,4)="S"
SET SPRV=+PRV
+10 IF $PIECE(PRV,U,5)="A"
SET APRV=+PRV
+11 IF $PIECE(PRV,U,5)="O"
SET OPRV=+PRV
End DoDot:1
+12 ;PRFM - NULL, THEN PRV PRIMARY
IF IBBFT1(20)=""
SET IBBFT1(20)=$GET(PPRV)
+13 SET IBBCTYPE=$SELECT(TYPE="BEFORE":"CD",1:"CG")
SET IBBFT1(10)=$PIECE(CD,U,16)
+14 SET (IBBFT1(13),I)=$SELECT($PIECE(CD,U,19)]"":$PIECE(CD,U,19),1:999)
SET IBBFT1(4)=$SELECT(CD12:+CD12,1:VDT)
+15 SET IBBPR1(3)=+CD
SET IBBPR1(5)=IBBFT1(4)
+16 IF "180^401^402^403^404^406^407^409^410^411^412^413^415^457"[I
Begin DoDot:1
+17 SET IBBPR1(11,1)=$GET(OPRV)
IF IBBPR1(11,1)=""
SET IBBPR1(11,1)=IBBFT1(20)
+18 SET IBBPR1(11,2)=$GET(APRV)
End DoDot:1
+19 NEW IBBARFNZ
IF $EXTRACT($TEXT(ORACTREF^ORWPFSS),9)="("
IF I=108
IF IBBORIEN
DO ORACTREF^ORWPFSS(.IBBARFNZ,.IBBORIEN)
IF IBBARFNZ]""
SET IBBARFN=IBBARFNZ
+20 SET MOD=""
SET I=0
+21 FOR
SET I=$ORDER(^TMP("PXKCO",$JOB,PXKVVST,"CPT",CDI,1,TYPE,I))
if I=""
QUIT
SET MOD=$SELECT(MOD="":I,1:MOD_";"_I)
+22 SET I=0
FOR
SET I=$ORDER(^TMP("PXKCO",$JOB,PXKVVST,"POV",I))
if I=""
QUIT
Begin DoDot:1
+23 SET DXS=$GET(^(I,0,TYPE))
+24 SET DXS(+DXS)=$GET(^TMP("PXKCO",$JOB,PXKVVST,"POV",I,800,TYPE))
End DoDot:1
+25 SET IBBPR1(16)=MOD
+26 ;SHAD
FOR I=1:1:8
SET SC(I)=""
+27 SET FDX=1
FOR I=5,9:1:15
SET DX=$PIECE(CD,U,I)
IF DX
SET J=$SELECT(I=5:1,1:I-7)
Begin DoDot:1
+28 SET IBBDG1(J,3)=DX
SET IBBDG1(J,6)="F"
SET DXS=$GET(DXS(DX))
+29 ;SHAD
FOR J=1:1:8
IF 'SC(J)
Begin DoDot:2
+30 IF $PIECE($GET(DXS(DX)),U,J)
SET SC(J)=1
QUIT
+31 IF $PIECE($GET(DXS(DX)),U,J)=""
SET SC(J)=""
QUIT
+32 IF $PIECE($GET(DXS(DX)),U,J)=0
IF FDX=1
SET SC(J)=0
End DoDot:2
End DoDot:1
SET FDX=0
+33 SET SC=$GET(^TMP("PXKCO",$JOB,PXKVVST,"VST",PXKVVST,800,TYPE))
+34 ;SHAD
FOR I=1:1:8
IF SC(I)=""
SET SC(I)=$PIECE(SC,U,I)
+35 ;SHAD
FOR I=1:1:8
SET J=$SELECT(I=1:3,I=2:1,I=3:2,1:I)
SET IBBZCL(J,2)=J
SET IBBZCL(J,3)=SC(I)
+36 IF IBBZCL(3,3)
FOR I=1,2,4
SET IBBZCL(I,3)=""
+37 WRITE $$CHARGE^IBBAPI(IBBDFN,IBBARFN,IBBCTYPE,IBBUCID,.IBBFT1,.IBBPR1,.IBBDG1,.IBBZCL,.IBBRXE,IBBORIEN,.IBBPROS)
+38 QUIT
LD(ND) SET IBBDFN=$PIECE(ND,U,5)
SET IBBARFN=$PIECE(ND,U,26)
SET VDT=+ND
+1 QUIT
