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

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1IBCNRP ;DAOU/ALA - Plan Match ListMan ;13-NOV-2003
2 ;;2.0;INTEGRATED BILLING;**251**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;; ;
5EN ; -- main entry point for IBCNR PLAN MATCH
6 D EN^VALM("IBCNR PLAN MATCH")
7 Q
8 ;
9HDR ; -- header code
10 NEW IBCNS0,IBCNS11,IBCNS13,IBLEAD,X,X1,X2
11 S IBCNS0=$G(^DIC(36,+IBCNSP,0))
12 S IBCNS11=$G(^DIC(36,+IBCNSP,.11))
13 S IBCNS13=$G(^DIC(36,+IBCNSP,.13))
14 S X2=$S(IBW:"",1:"Active ")
15 S IBLEAD=$S(IBIND:"All "_X2,1:X2_"Group ")_"Plans for: "
16 S X="Phone: "_$S($P(IBCNS13,"^")]"":$P(IBCNS13,"^"),1:"<not filed>")
17 S VALMHDR(1)=$$SETSTR^VALM1(X,IBLEAD_$P(IBCNS0,"^"),81-$L(X),40)
18 S X1="Precerts: "_$S($P(IBCNS13,"^",3)]"":$P(IBCNS13,"^",3),1:"<not filed>")
19 S X=$TR($J("",$L(IBLEAD)),""," ")_$S($P(IBCNS11,"^")]"":$P(IBCNS11,"^"),1:"<no street address>")
20 S VALMHDR(2)=$$SETSTR^VALM1(X1,X,81-$L(X1),40)
21 S X=$S($P(IBCNS11,"^",4)]"":$P(IBCNS11,"^",4),1:"<no city>")_", "
22 S X=X_$S($P(IBCNS11,"^",5):$P($G(^DIC(5,$P(IBCNS11,"^",5),0)),"^",2),1:"<no state>")_" "_$E($P(IBCNS11,"^",6),1,5)_$S($E($P(IBCNS11,"^",6),6,9)]"":"-"_$E($P(IBCNS11,"^",6),6,9),1:"")
23 S VALMHDR(3)=$$SETSTR^VALM1(X,"",$L(IBLEAD)+1,80)
24 S X="#" I $G(IBIND) S X="# + => Indiv. Plan"
25 I $G(IBW) S X=$E(X_$J("",23),1,23)_"* => Inactive Plan"
26 S VALMHDR(4)=$$SETSTR^VALM1(" ",X,64,17)
27 Q
28 ;
29INIT ; -- init variables and list array
30 NEW IBGP0,IBCPOLD,X,IBCPD6,IBCNRPP,IBCOV,IBCRVD,LIM
31 K ^TMP("IBCNR",$J)
32 S VALMCNT=0,VALMBG=1
33 S IBGP0=^IBA(355.3,+IBCNGP,0)
34 I $G(IBGP0) D
35 . ;S IBCPD6=$G(IBGP0,U,6)) ;chk pre-cert
36 . ;I 'IBIND,'$P(IBGP0,"^",2) Q ; exclude individual plans
37 . ;I 'IBW,$P(IBGP0,"^",11) Q ; plan is inactive
38 . ;
39 . S VALMCNT=VALMCNT+1
40 . S X=$$SETFLD^VALM1(VALMCNT,"","NUMBER")
41 . ;
42 . I '$P(IBGP0,"^",2) S $E(X,4)="+"
43 . S X=$$SETFLD^VALM1($P(IBGP0,"^",3),X,"GNAME")
44 . ;
45 . I $P(IBGP0,"^",11) S $E(X,24)="*"
46 . S X=$$SETFLD^VALM1($P(IBGP0,"^",4),X,"GNUM")
47 . ;
48 . S X=$$SETFLD^VALM1($$EXPAND^IBTRE(355.3,.09,$P(IBGP0,"^",9)),X,"TYPE")
49 . ;
50 . S IBCNRPP=$$GET1^DIQ(355.3,IBCNGP_",",6.01,"I")
51 . I IBCNRPP'="" S IBCNRPP=$$GET1^DIQ(366.03,IBCNRPP_",",.02,"E")
52 . S X=$$SETFLD^VALM1(IBCNRPP,X,"PHARM")
53 . ;
54 . S IBCOV=$O(^IBE(355.31,"B","PHARMACY",""))
55 . S LIM="",IBCVRD=0
56 . F S LIM=$O(^IBA(355.32,"B",IBCNGP,LIM)) Q:LIM="" D
57 .. I $P(^IBA(355.32,LIM,0),U,2)=IBCOV S IBCVRD=$P(^IBA(355.32,LIM,0),U,4)
58 . S X=$$SETFLD^VALM1($S(IBCVRD=0:"NO",1:"YES"),X,"COV")
59 . ;
60 . S ^TMP("IBCNR",$J,VALMCNT,0)=X
61 . S ^TMP("IBCNR",$J,"IDX",VALMCNT,VALMCNT)=IBCNGP
62 . I '$D(^TMP("IBCNR",$J)) S VALMCNT=2,^TMP("IBCNR",$J,1,0)=" ",^TMP("IBCNR",$J,2,0)=" No plans were identified for this company."
63 Q
64 ;
65HELP ; -- help code
66 S X="?" D DISP^XQORM1 W !!
67 Q
68 ;
69EXIT ; -- exit code
70 K ^TMP("IBCNR",$J),VALMBCK,VALMY
71 D CLEAN^VALM10,CLEAR^VALM1
72 Q
73 ;
74EXPND ; -- expand code
75 Q
76 ;
77SEL ; -- select plan
78 D S1
79 I 'IBX Q ; no group selected
80 ;
81 NEW DA,DIC,DIE,DR,D,IBPLN
82 S DIC="^IBCNR(366.03,",DIC(0)="AEMNZ" D ^DIC
83 I +Y<1 S D="F" D IX^DIC
84 I +Y<1 G SPQ
85 S IBPLN=+Y K Y,X
86 D PLCK ; check plan status
87 S DA=IBSEL,DIC="^IBA(355.3,",DIE=DIC,DR="6.01////^S X="_IBPLN
88 D ^DIE
89 D INIT
90 ;
91 S IBX=0 F S IBX=$O(VALMY(IBX)) Q:'IBX S ^TMP($J,"IBSEL",+$G(^TMP("IBCNR",$J,"IDX",IBX,IBX)))=""
92 ;
93 D SPQ
94 Q
95 ;
96PLCK ; -- check plan status
97 NEW ARRAY
98 D STCHK^IBCNRU1(IBPLN,.ARRAY)
99 I $G(ARRAY(1))'="A" D
100 . W !!,"WARNING....PLAN NOT ACTIVE!"
101 ;
102 Q
103 ;
104DEL ; -- remove a plan from a group
105 D S1
106 ;
107 NEW DA,DIC,DIE,DR
108 S DA=IBSEL,DIC="^IBA(355.3,",DIE=DIC,DR="6.01///@"
109 D ^DIE
110 D INIT
111 ;
112 S IBX=0 F S IBX=$O(VALMY(IBX)) Q:'IBX S ^TMP($J,"IBSEL",+$G(^TMP("IBCNR",$J,"IDX",IBX,IBX)))=""
113 ;
114 D SPQ
115 Q
116 ;
117S1 ;
118 NEW DIR,DIRUT,DUOUT,DTOUT,DIROUT,IBOK,IBQUIT,Y
119 D EN^VALM2($G(XQORNOD(0)),"S"),FULL^VALM1
120 S IBX=$O(VALMY(0)),VALMBCK="R"
121 ;
122 I 'IBX W !!,"No group selected!" G SPQ
123 I 'IBMULT D G SPQ
124 . I $O(VALMY(IBX)) W !!,*7,"You may only select a single plan!" Q
125 . I $G(IBALR),+$G(^TMP("IBCNR",$J,"IDX",IBX,IBX))=IBALR W !!,*7,"This plan is not allowed for selection!" Q
126 . D OK^IBCNSM3
127 . I IBQUIT S VALMBCK="Q" Q
128 . I IBOK S IBSEL=+$G(^TMP("IBCNR",$J,"IDX",IBX,IBX)),VALMBCK="Q"
129 ;
130 S IBSEL=+$G(^TMP("IBCNR",$J,"IDX",IBX,IBX))
131 Q
132 ;
133SPQ ;
134 I '$O(IBSEL(0)),VALMBCK="R" D PAUSE^VALM1
135 Q
Note: See TracBrowser for help on using the repository browser.