source: FOIAVistA/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBIBB.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.0 KB
Line 
1PXBIBB ;ALB/DWS/BDB - SEND CHARGE OR CREDIT TRANSACTIONS TO IBB ;8/10/05 1:29pm
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**164**;Aug 12, 1996
3 N VSTB,PKB,VSTA,PKA,PRVB,PRVA,SC,IBBAPLR,IBBDFN
4 N IBBARFN,IBBUCID,CD,CD12,CDA,CDB,CDI,DX,IO,MOD
5 N IBBCTYPE,IBBORIEN,ND,TYPE,VDT,PPRV,SPRV,APRV,OPRV,ORY
6 S VSTA=$G(^TMP("PXKCO",$J,PXKVVST,"VST",PXKVVST,0,"AFTER"))
7 S PKA=$G(^TMP("PXKCO",$J,PXKVVST,"VST",PXKVVST,812,"AFTER"))
8 S IO=$P($G(^TMP("PXKCO",$J,PXKVVST,"VST",PXKVVST,150,"AFTER")),U,2)
9 S VSTB=$G(^TMP("PXKCO",$J,PXKVVST,"VST",PXKVVST,0,"BEFORE"))
10 S PKB=$G(^TMP("PXKCO",$J,PXKVVST,"VST",PXKVVST,812,"BEFORE"))
11 S:IO="" IO=$P($G(^TMP("PXKCO",$J,PXKVVST,"VST",PXKVVST,150,"BEFORE")),U,2)
12 Q:$P(VSTB,U,7)="E" Q:$P(VSTA,U,7)="E"
13 Q:$P(PKB,U,2)=$$PKG2IEN^VSIT("RMPR") Q:$P(PKA,U,2)=$$PKG2IEN^VSIT("RMPR")
14 S SC=$O(^SCE("AVSIT",PXKVVST,0))
15 S:'SC SC=$O(^TMP("PXKCO",$J,PXKVVST,"OE",0)) D:'SC Q:'SC
16 .Q:'IO
17 .S CDI=0 F S CDI=$O(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI)) Q:CDI="" D
18 ..S CDB=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,0,"BEFORE"))
19 ..I $P(CDB,U)'="" S CD=CDB,CD12=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,12,"BEFORE")) D CHG("BEFORE")
20 ..S CDA=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,0,"AFTER"))
21 ..I $P(CDA,U)'="" S CD=CDA,CD12=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,12,"AFTER")) D CHG("AFTER")
22 S BSTATUS=$P($G(^TMP("PXKCO",$J,PXKVVST,"OE",SC,0,"BEFORE")),U,7)
23 I '$P($G(^SCE(SC,0)),U,7) Q:'BSTATUS D Q
24 .S CDI=0 F S CDI=$O(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI)) Q:CDI="" D
25 ..S CD=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,0,"BEFORE"))
26 ..S CD12=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,12,"BEFORE"))
27 ..D CHG("BEFORE")
28 S CDI=0 F S CDI=$O(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI)) Q:CDI="" D
29 .S:BSTATUS CDB=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,0,"BEFORE"))
30 .S CDA=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,0,"AFTER"))
31 .I BSTATUS,$P(CDA,U)="" D D CHG("BEFORE") Q
32 ..S CD=CDB,CD12=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,12,"BEFORE"))
33 .S CD=CDA,CD12=$G(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,12,"AFTER"))
34 .D CHG("AFTER")
35 Q
36CHG(TYPE) ;PROCESS DEBITS OR CREDITS, BEFORE = CREDIT, AFTER = DEBIT
37 N IBBFT1,IBBPR1,IBBDG1,IBBZCL,DXS,FDX,I
38 D LD($S(VSTA:VSTA,1:VSTB))
39 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
40 I 'IBBUCID S IBBUCID=$$GETCHGID^IBBAPI(),DA=CDI,DR=".2///"_IBBUCID D
41 .S DIE="^AUPNVCPT(" D ^DIE
42 S I="" F S I=$O(^TMP("PXKCO",$J,PXKVVST,"PRV",I)) Q:I="" D
43 .S PRV=$G(^TMP("PXKCO",$J,PXKVVST,"PRV",I,0,TYPE))
44 .I $P(PRV,U,4)="P" S PPRV=+PRV
45 .I $P(PRV,U,4)="S" S SPRV=+PRV
46 .I $P(PRV,U,5)="A" S APRV=+PRV
47 .I $P(PRV,U,5)="O" S OPRV=+PRV
48 I IBBFT1(20)="" S IBBFT1(20)=$G(PPRV) ;PRFM - NULL, THEN PRV PRIMARY
49 S IBBCTYPE=$S(TYPE="BEFORE":"CD",1:"CG"),IBBFT1(10)=$P(CD,U,16)
50 S (IBBFT1(13),I)=$S($P(CD,U,19)]"":$P(CD,U,19),1:999),IBBFT1(4)=$S(CD12:+CD12,1:VDT)
51 S IBBPR1(3)=+CD,IBBPR1(5)=IBBFT1(4)
52 I "180^401^402^403^404^406^407^409^410^411^412^413^415^457"[I D
53 .S IBBPR1(11,1)=$G(OPRV) I IBBPR1(11,1)="" S IBBPR1(11,1)=IBBFT1(20)
54 .S IBBPR1(11,2)=$G(APRV)
55 N IBBARFNZ I $E($T(ORACTREF^ORWPFSS),9)="(",I=108,IBBORIEN D ORACTREF^ORWPFSS(.IBBARFNZ,.IBBORIEN) I IBBARFNZ]"" S IBBARFN=IBBARFNZ
56 S MOD="",I=0
57 F S I=$O(^TMP("PXKCO",$J,PXKVVST,"CPT",CDI,1,TYPE,I)) Q:I="" S MOD=$S(MOD="":I,1:MOD_";"_I)
58 S I=0 F S I=$O(^TMP("PXKCO",$J,PXKVVST,"POV",I)) Q:I="" D
59 .S DXS=$G(^(I,0,TYPE))
60 .S DXS(+DXS)=$G(^TMP("PXKCO",$J,PXKVVST,"POV",I,800,TYPE))
61 S IBBPR1(16)=MOD
62 F I=1:1:8 S SC(I)="" ;SHAD
63 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
64 .S IBBDG1(J,3)=DX,IBBDG1(J,6)="F",DXS=$G(DXS(DX))
65 .F J=1:1:8 I 'SC(J) D ;SHAD
66 ..I $P($G(DXS(DX)),U,J) S SC(J)=1 Q
67 ..I $P($G(DXS(DX)),U,J)="" S SC(J)="" Q
68 ..I $P($G(DXS(DX)),U,J)=0,FDX=1 S SC(J)=0
69 S SC=$G(^TMP("PXKCO",$J,PXKVVST,"VST",PXKVVST,800,TYPE))
70 F I=1:1:8 I SC(I)="" S SC(I)=$P(SC,U,I) ;SHAD
71 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
72 I IBBZCL(3,3) F I=1,2,4 S IBBZCL(I,3)=""
73 W $$CHARGE^IBBAPI(IBBDFN,IBBARFN,IBBCTYPE,IBBUCID,.IBBFT1,.IBBPR1,.IBBDG1,.IBBZCL,.IBBRXE,IBBORIEN,.IBBPROS)
74 Q
75LD(ND) S IBBDFN=$P(ND,U,5),IBBARFN=$P(ND,U,26),VDT=+ND
76 Q
Note: See TracBrowser for help on using the repository browser.