- 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 Feb 18, 2025@23:53:15 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
