source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC4E.m@ 1042

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

initial load of WorldVistAEHR
File size: 6.1 KB
RevLine 
[613]1IBCSC4E ;ALB/ARH - ADD/ENTER PTF/OE DIAGNOSIS ;3/2/94
2 ;;2.0;INTEGRATED BILLING;**8,106,121,124,210,266**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5DXINPT(IBIFN) ; display and ask user to select PTF diagnosis
6 N IBLIST,IBPTFDX
7 D PTFDSP(IBIFN),PTFASK I $D(IBLIST) D PTFADD(IBIFN,IBLIST)
8 K ^TMP($J,"IBDX")
9 Q
10 ;
11PTFASK ;
12 D PTF Q:$G(IBPTFDX)'>0 N X,Y,DIR,DIRUT K IBLIST W !
13PTFASK1 S DIR("A")="SELECT DIAGNOSIS FROM THE PTF RECORD TO INCLUDE ON THE BILL"
14 S DIR("?",1)="Enter the alphanumeric preceding the diagnosis you want added to the bill.",DIR("?",2)=""
15 S DIR("?",3)="To enter more than one separate them by a comma or within a movement use a"
16 S DIR("?",4)="range separated by a dash. * indicates the diagnosis is already on the bill."
17 S DIR("?")="The print order for each diagnosis will be determined by the order in this list."
18 S DIR(0)="FO^^D ITPTF^IBCSC4E" D ^DIR K DIR Q:$D(DIRUT)!(Y="")
19 ;
20 S X=Y D ITPTF S IBLIST=X,DIR("A",1)="YOU HAVE SELECTED "_X_" TO BE ADDED TO THE BILL",DIR("A")="IS THIS CORRECT",DIR("B")="YES"
21 S DIR(0)="YO" D ^DIR K DIR I $D(DIRUT) K IBLIST Q
22 I 'Y K IBLIST G PTFASK1
23 Q
24 ;
25PTF ;
26 Q:'$D(^TMP($J,"IBDX","S")) N IBX,IBY,IBZ,IBORD,IBNUM K IBPTFDX S IBORD="",IBPTFDX=0
27 S IBX="" F S IBX=$O(^TMP($J,"IBDX","S",IBX)) Q:IBX="" D
28 . S IBZ=+$G(^TMP($J,"IBDX","S",IBX)) Q:'IBZ
29 . S IBORD=$E(IBX) Q:IBORD'?1A S IBNUM=+$E(IBX,2,999) Q:IBNUM'>0
30 . I IBNUM>$G(IBPTFDX(IBORD)) S IBPTFDX(IBORD)=IBNUM
31 . I '$D(^IBA(362.3,"AIFN"_+$G(IBIFN),+IBZ)) S IBPTFDX=IBPTFDX+1
32 Q
33 ;
34ITPTF ;
35 N IBI,IB1,IB2,IB3,IBJ,IBX,IBY,IBZ,IBA
36 S IBA="",IBX=X
37 F IBI=1:1 S IBY=$P(IBX,",",IBI) Q:IBY="" D Q:'$D(X) S X=IBA
38 . I IBY["-" S IBZ=$P(IBY,"-",1),IB2=$P(IBY,"-",2) D Q:'$D(X)
39 .. I $E(IBZ,1)'=$E(IB2,1) K X Q
40 .. S IBY="",IB1=$E(IBZ,2,999),IB2=$E(IB2,2,999),IBZ=$E(IBZ,1) I +IB2'>+IB1 K X Q
41 .. F IBJ=IB1:1:IB2 S IBY=IBY_IBZ_IBJ_"-" I IBJ>$G(IBPTFDX(IBZ)) Q
42 . F IBJ=1:1 S IB1=$P(IBY,"-",IBJ) Q:IB1="" S IB2=$E(IB1,1),IB3=$E(IB1,2,99) D Q:'$D(X)
43 .. I IB1'?1U1.3N K X Q
44 .. I IB2=""!'IB3 K X Q
45 .. I '$D(IBPTFDX(IB2)) K X Q
46 .. I IB3>+$G(IBPTFDX(IB2)) K X Q
47 .. S IBA=IBA_IB2_IB3_","
48 Q
49 ;
50PTFADD(IBIFN,LIST) ;
51 Q:'$D(^TMP($J,"IBDX","S"))!($G(LIST)="")!('$G(IBIFN)) N IBX,IBY,IBI,IBCD,IBDX
52 F IBI=1:1 S IBCD=$P(LIST,",",IBI) Q:IBCD="" D
53 . S IBDX=+$G(^TMP($J,"IBDX","S",IBCD)) Q:'IBDX
54 . I ($$ICD9^IBACSV(+IBDX)'=""),'$D(^IBA(362.3,"AIFN"_IBIFN,+IBDX)) I $$ADD^IBCSC4D(+IBDX,IBIFN) W "."
55 Q
56 ;
57PTFDSP(IBIFN) ; display PTF diagnosis within date range of the bill
58 ; Output: ^TMP($J,"IBDX") as defined by PTFDXDT^IBCSC4F and
59 ; ^TMP($J,"IBDX","S",x) = DIAGNOSIS w/x=selection identifer for a dx
60 N IB0,IBPTF,IBTF,IBU,IBFDT,IBTDT,IBDSCH,IBW,IBC,IBA,IBN,IBCNT,IBMCNT,IBMDT,IBMV,IBDT,IBLN,IBLABEL,IBDXCNT,IBI
61 N IBDX,IBID,IBON,IBY,IBMDRG,X,IBDATE
62 ;
63 K ^TMP($J,"IBDX") S IBW=41
64 ;
65 S IBDATE=$$BDATE^IBACSV(IBIFN) ; The Event Date of the bill
66 S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBPTF=$P(IB0,U,8),IBTF=$P(IB0,U,6) Q:'$G(IBPTF)
67 S IBU=$G(^DGCR(399,+IBIFN,"U")),IBFDT=+IBU,IBTDT=$P(IBU,U,2) Q:$P(IB0,U,5)>2
68 ;
69 D PTFDXDT^IBCSC4F(IBPTF,IBFDT,IBTDT,IBTF) S IBDSCH=$P(+$P($G(^TMP($J,"IBDX","M")),U,3),".")
70 ;
71 F IBN="M","D" S (IBCNT,IBMCNT,IBMDT)="" F S IBMDT=$O(^TMP($J,"IBDX",IBN,IBMDT)) Q:'IBMDT S IBMCNT=IBMCNT+1 D
72 . S IBMV=$G(^TMP($J,"IBDX",IBN,IBMDT)),IBDT=+IBMV,IBMDRG=$P(IBMV,U,4)
73 . I IBN="M" S IBC=0,IBLABEL="Move",IBA=$C(64+IBMCNT) I 'IBDT S IBDT="D/C"
74 . I IBN="D" S IBC=41,IBLABEL="Discharge",IBA="X" I 'IBDT S IBDT="NOT DISCHARGED"
75 . ;
76 . S IBLN=IBLABEL_": "_$S(+IBDT:$P($$FMTE^XLFDT(+IBDT,2),"@",1),1:IBDT)
77 . S IBLN=IBLN_" "_$E($P($G(^DIC(42.4,+$P(IBMV,U,2),0)),U,1),1,12)
78 . S IBLN=IBLN_" "_$J("",(29-$L(IBLN)))_$S(+$P(IBMV,U,3):"<SC>",1:"<NSC>")
79 . ;
80 . S IBCNT=IBCNT+1,X(IBCNT)=$G(X(IBCNT))_$J("",IBW)
81 . S IBCNT=IBCNT+1,X(IBCNT)=$G(X(IBCNT))_$J("",IBW),X(IBCNT)=$E(X(IBCNT),1,IBC)_IBLN
82 . ;
83 . I '$O(^TMP($J,"IBDX",IBN,IBMDT,"")) S IBCNT=IBCNT+1,X(IBCNT)=$G(X(IBCNT))_$J("",IBW),X(IBCNT)=$E(X(IBCNT),1,IBC)_" No DX Codes Entered For "_IBLABEL
84 . ;
85 . S (IBDXCNT,IBI)="" F S IBI=$O(^TMP($J,"IBDX",IBN,IBMDT,IBI)) Q:'IBI D
86 .. S IBDX=^TMP($J,"IBDX",IBN,IBMDT,IBI),IBY=$$ICD9^IBACSV(+IBDX,IBDATE)
87 .. S IBDXCNT=IBDXCNT+1,IBID=IBA_IBDXCNT,IBON=$S($O(^IBA(362.3,"AIFN"_IBIFN,+IBDX,"")):"*",1:" ")
88 .. ;
89 .. S IBLN=" "_IBON_IBID_" - "_$P(IBY,U,1)_$J("",(7-$L($P(IBY,U,1))))_$E($P(IBY,U,3),1,23)
90 .. S IBCNT=IBCNT+1,X(IBCNT)=$G(X(IBCNT))_$J("",IBW),X(IBCNT)=$E(X(IBCNT),1,IBC)_IBLN
91 .. S ^TMP($J,"IBDX","S",IBID)=IBDX
92 . ;
93 . I 'IBMDRG,IBN="M" S IBLN=" *** No DRG for Charges ***",IBCNT=IBCNT+1,X(IBCNT)=$G(X(IBCNT))_$J("",IBW),X(IBCNT)=$E(X(IBCNT),1,IBC)_IBLN
94 . I IBMDRG S IBLN=$P($$DRG^IBACSV(+IBMDRG,IBDATE),U,1)_" - "_$E($$DRGTD^IBACSV(+IBMDRG,IBDATE),1,30),IBCNT=IBCNT+1,X(IBCNT)=$G(X(IBCNT))_$J("",IBW),X(IBCNT)=$E(X(IBCNT),1,IBC)_IBLN
95 ;
96 I IBDSCH,IBTDT<IBDSCH S IBCNT=2,X(IBCNT)=$G(X(IBCNT))_$J("",IBW),X(IBCNT)=$E(X(IBCNT),1,IBW)_"Discharge: "_$$FMTE^XLFDT(+$P(IBDSCH,"."),2)_" Not In Bill Range"
97 I 'IBDSCH,IBTDT<DT S IBCNT=2,X(IBCNT)=$G(X(IBCNT))_$J("",IBW),X(IBCNT)=$E(X(IBCNT),1,IBW)_"Discharge: NOT DISCHARGED"
98 ;
99 W @IOF,"=============================== Diagnosis Screen ==============================="
100 S IBI="" F S IBI=$O(X(IBI)) Q:'IBI W !,$E(X(IBI),1,80)
101 Q
102 ;
103DELALL(IBIFN) ; ask/delete all diagnosis on a bill, including all CPT associated Diagnosis
104 Q:'$O(^IBA(362.3,"AIFN"_+$G(IBIFN),0))
105 ;
106 N DIR,DIRUT,DUOUT,DTOUT,X,Y,DIK W !
107 S DIR("?")="Enter Yes to delete all Diagnosis currently defined for a bill, including any CPT Associated Diagnosis.",DIR("??")="^D DISP1^IBCSC4D("_IBIFN_")"
108 S DIR("A")="DELETE ALL DIAGNOSIS ON BILL, INCLUDING CPT ASSOCIATED DIAGNOSIS"
109 S DIR(0)="YO",DIR("B")="NO" D ^DIR K DIR Q:Y'=1
110 ;
111 N IBPROC,IBPROCD,IBXRF,IBDX,IBDXI,DIE,DIC,DA,DR
112 S IBPROC=0 F S IBPROC=$O(^DGCR(399,IBIFN,"CP",IBPROC)) Q:'IBPROC D
113 . S IBPROCD=$G(^DGCR(399,IBIFN,"CP",IBPROC,0)) I "^^^"[$P(IBPROCD,U,11,14) Q
114 . S DIE="^DGCR(399,"_IBIFN_",""CP"",",DA=IBPROC,DA(1)=IBIFN,DR="10///@;11///@;12///@;13///@" D ^DIE K DA,DIE,DR
115 ;
116 S IBXRF="AIFN"_+IBIFN
117 S IBDX=0 F S IBDX=$O(^IBA(362.3,IBXRF,IBDX)) Q:'IBDX D
118 . S IBDXI=0 F S IBDXI=$O(^IBA(362.3,IBXRF,IBDX,IBDXI)) Q:'IBDXI D
119 .. S DIK="^IBA(362.3,",DA=IBDXI D ^DIK K DIK,DA
120 W " .... deleted"
121 Q
Note: See TracBrowser for help on using the repository browser.