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

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

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1IBCU72 ;ALB/CPM - ADD/EDIT/DELETE PROCEDURE DIAGNOSES ;18-JUN-96
2 ;;2.0;INTEGRATED BILLING;**62,210**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5DX(IBIFN,IBPROC) ; Add/edit/delete procedure diagnoses.
6 ; Input: IBIFN -- Pointer to the claim in file #399
7 ; IBPROC -- Pointer to the claim procedure in file #399.0304
8 ;
9 I '$G(IBIFN) G DXQ
10 I '$G(IBPROC) G DXQ
11 ;
12 N DIE,DA ; need to preserve these variables for IBCU7.
13 ;
14 N IBPROCD,IBDX,IBDXSCR,IBLINE,IBI,IBDEF,IBQUIT,IBPROMPT
15 S IBPROCD=$G(^DGCR(399,IBIFN,"CP",IBPROC,0))
16 I 'IBPROCD G DXQ
17 ;
18 ; - get diagnoses and display.
19 D SET^IBCSC4D(IBIFN,.IBDXSCR,.IBDX),DISP(.IBDX)
20 I '$O(IBDX(0)) W "There are no diagnoses associated with this bill." G DXQ
21 ;
22 ; - build workable array; determine default values
23 S IBI=0 F S IBI=$O(IBDX(IBI)) Q:'IBI S IBDX(IBI)=IBDXSCR(+IBDX(IBI))_U_$P($$ICD9^IBACSV(+IBDX(IBI)),U)
24 S IBDEF="" F I=11:1:14 S X=$P(IBPROCD,U,I) I X D
25 . S J=0 F S J=$O(IBDX(J)) Q:'J I +IBDX(J)=X S IBDEF=IBDEF_J_":"_$P(IBDX(J),U,2)_"," Q
26 I IBDEF]"" S IBDEF=$E(IBDEF,1,$L(IBDEF)-1)
27 ;
28 ; - display instructions and default values
29 W !," *** Please select procedure diagnoses by number to left of diagnosis code ***"
30 I IBDEF]"" W !,"Current Values: " F I=1:1:$L(IBDEF,",") S X=$P(IBDEF,",",I) I X]"" W "Dx ",I,": ",+X," - ",$P(X,":",2)," "
31 ;
32 ; - prompt for the four associated dx prompts
33 W ! S IBQUIT=0 F IBPROMPT=1:1:4 D ASKEM Q:IBQUIT
34 ;
35DXQ Q
36 ;
37 ;
38 ;
39DISP(X) ; Display of existing dx's for a bill.
40 N IBX,IBY,IBZ,IBDATE
41 S IBDATE=$$BDATE^IBACSV($G(IBIFN))
42 W !!,?5,"----------------- Existing Diagnoses for Bill -----------------",!
43 S IBX=0 F S IBX=$O(X(IBX)) Q:'IBX S IBZ=X(IBX),IBY=$$ICD9^IBACSV(+IBZ,IBDATE) D
44 . W !?5,IBX,".",?12,$P(IBY,U),?26,$P(IBY,U,3),?60,$S($P(IBZ,U,2)<1000:"("_$P(IBZ,U,2)_")",1:"")
45 W !
46 Q
47 ;
48ASKEM ; Allow entry of the procedure diagnoses.
49 N IBP
50 S IBP=$P(IBDEF,",",IBPROMPT)
51 W !,"Associated Diagnosis (",IBPROMPT,"): ",$S(IBP]"":+IBP_" - "_$P(IBP,":",2)_" // ",1:"")
52 R X:DTIME
53 I $E(X)="^" S IBQUIT=1 G ASKEMQ
54 I $E(X)="@" D:IBP]"" UPD("@",IBPROMPT+9) W:IBP]"" " deleted." G ASKEMQ
55 I $E(X)="?" D HELP1 G ASKEM
56 I X="" S:'$$NEXT() IBQUIT=1 G ASKEMQ
57 I '$D(IBDX(X)) D HELP1 G ASKEM
58 W " ",$P(IBDX(X),"^",2)
59 I +IBP'=X D UPD("/"_+IBDX(X),IBPROMPT+9)
60ASKEMQ Q
61 ;
62UPD(IBVALUE,IBFIELD) ; Update an associated diagnosis.
63 S DIE="^DGCR(399,"_IBIFN_",""CP"",",DA=IBPROC,DA(1)=IBIFN
64 S DR=IBFIELD_"///"_IBVALUE D ^DIE K DA,DIE,DR
65 Q
66 ;
67HELP1 ; Help for entering associated diagnoses.
68 N X
69 W !!,"Please enter one of the following billing diagnoses by number at left of code:"
70 S X=0 F S X=$O(IBDX(X)) Q:'X W:X#4=1 ! W ?((X-1)#4*18),X,".",$J($P(IBDX(X),"^",2),9)
71 W !!,"You may also enter '^' to exit, '@' to delete a procedure diagnosis, or"
72 W !,"<CR> to accept a current value or skip a prompt.",!
73 Q
74 ;
75NEXT() ; Advance to the next prompt?
76 N I,X S X=0
77 I IBPROMPT=4 G NEXTQ
78 I IBP]"" S X=1 G NEXTQ
79 F I=(IBPROMPT+1):1:4 I $P(IBDEF,",",I)]"" S X=1 Q
80NEXTQ Q X
Note: See TracBrowser for help on using the repository browser.