source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBPST35B.m@ 1806

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

initial load of WorldVistAEHR
File size: 3.3 KB
Line 
1FBPST35B ;ACAMPUS/DMK-CONVERT FILE 163.99
2 ;;3.5;FEE BASIS;;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;This post-init routine goes through file 163.99 and converts the .01
5 ;field from a pointer to the CPT file(#81) to the external value.
6 ;The .01 field is converted to free text with this install to allow
7 ;for the incorperation of CPT Modifiers to the Fee Schedule.
8 ;
9 Q:+$G(^DD(163.99,0,"VR"))>3
10 W !!,"Beginning FBPST35B ....",!!?18,"CONVERSION OF FEE BASIS FEE SCHEDULE FILE (#163.99)"
11 N FBI,FBX,DA,DIE,DR,X
12 S FBI=0
13 F S FBI=$O(^FBAA(163.99,FBI)) Q:'FBI I $D(^(FBI,0)) D
14 . S DA=FBI Q:'$D(^ICPT(FBI,0)) S FBX=$P(^(0),U)
15 . S DIE="^FBAA(163.99,",DR=".01////^S X=FBX" D ^DIE
16 ;clean up old PT node in file 81
17 K ^DD(81,0,"PT",163.99,.01)
18 W !!,"Completed FBPST35B " D NOW^%DTC W $$DATX^FBAAUTL(%)
19 Q
20VENDOR ;clean up invalid ID entries still in 161.25
21 S FBI=0 F S FBI=$O(^FBAA(161.25,FBI)) Q:'FBI S FBL=+$P($G(^FBAA(161.25,FBI,0)),U,6) D
22 .I FBL,(FBI'=FBL) Q
23 .S FBJ=0 F S FBJ=$O(^FBAA(161.25,"AF",FBI,FBJ)) Q:'FBJ I (FBI'=FBJ) S FBOUT=1 Q
24 .I $G(FBOUT) K FBOUT Q
25 .S FBID=$P($G(^FBAAV(FBI,0)),U,2) I FBID']""!($A(FBID)=45)!($L(FBID)>11)!($L(FBID)<9)!(+FBID=0)!(FBID'?9N.2AN) D
26 ..S FB(FBI)=""
27 ..S DIK="^FBAA(161.25,",DA=FBI D ^DIK K DIK,DA
28 ..S DIE="^FBAAV(",DA=FBI,DR="9////^S X=""Y"";13///^S X=""T""" D ^DIE K DIE,DA,DR
29 I '$D(FB) G END
30 S PAD=" ",$P(PAD," ",40)="",FBCTR=2,FBTEXT(1,0)="The following vendors with invalid ID's have been placed in delete status:",FBTEXT(2,0)=" "
31 S FBI=0 F S FBI=$O(FB(FBI)) Q:'FBI S FBCTR=FBCTR+1,FBTEXT((FBCTR),0)=" "_$E($$VNAME^FBNHEXP(FBI),1,30)_$E(PAD,$L($$VNAME^FBNHEXP(FBI))+1,40)_$$VID^FBNHEXP(FBI)
32 S XMSUB="FEE BASIS VENDOR CORRECTIONS CLEANUP",XMDUZ=.5,XMY("G.FEE")="",XMTEXT="FBTEXT(" D ^XMD K FBTEXT,XMDUZ,XMSUB,XMY,XMTEXT,XMZ,PAD,FBCTR
33END K FBI,FBJ,FBL,FBID,FB,X,Y,DIC
34 Q
35XREF ;fix cross-references in 162 and 162.1 on date finalized & cert fields
36 S ZTRTN="FIX^FBPST35B",ZTIO="",ZTDTH=$H D ^%ZTLOAD
37 K ZTSK
38 Q
39FIX ;outpatient x-ref fix on field date finalized
40 S FBV=0 F S FBV=$O(^FBAAC("AP",FBV)) Q:'FBV D
41 .S FBI=0 F S FBI=$O(^FBAAC("AP",FBV,FBI)) Q:'FBI D
42 ..S DFN=0 F S DFN=$O(^FBAAC("AP",FBV,FBI,DFN)) Q:'DFN D
43 ...S FBSDT=0 F S FBSDT=$O(^FBAAC("AP",FBV,FBI,DFN,FBSDT)) Q:'FBSDT D
44 ....S FBCPT=0 F S FBCPT=$O(^FBAAC("AP",FBV,FBI,DFN,FBSDT,FBCPT)) Q:'FBCPT D
45 .....I $P($G(^FBAAC(DFN,1,FBV,1,FBSDT,1,FBCPT,0)),"^",6)'=FBI D
46 ......K ^FBAAC("AK",FBI,DFN,FBV,FBSDT,FBCPT),^FBAAC("AP",FBV,FBI,DFN,FBSDT,FBCPT)
47 ......S FBPSA=$P($G(^FBAAC(DFN,1,FBV,1,FBSDT,1,FBCPT,0)),"^",12) I FBPSA K ^FBAAC("AQ",FBPSA,9999999-FBI,DFN,FBV,FBSDT,FBCPT)
48FIXRX ;fix Pharmacy Invoice x-ref on field date certified for payment
49 S FBI=0 F S FBI=$O(^FBAA(162.1,"AA",FBI)) Q:'FBI D
50 .S DFN=0 F S DFN=$O(^FBAA(162.1,"AA",FBI,DFN)) Q:'DFN D
51 ..S FBIN=0 F S FBIN=$O(^FBAA(162.1,"AA",FBI,DFN,FBIN)) Q:'FBIN D
52 ...S FBRX=0 F S FBRX=$O(^FBAA(162.1,"AA",FBI,DFN,FBIN,FBRX)) Q:'FBRX D
53 ....S FBDT=$P($G(^FBAA(162.1,FBIN,"RX",FBRX,0)),"^",19) D K FBDT
54 .....Q:FBDT=FBI
55 .....I FBDT,(FBDT'=FBI) S $P(^FBAA(162.1,FBIN,"RX",FBRX,0),"^",19)=FBI Q
56 .....K ^FBAA(162.1,"AA",FBI,DFN,FBIN,FBRX)
57 .....S FBPSA=$P($G(^FBAA(162.1,FBIN,"RX",FBRX,2)),"^",5) I FBPSA K ^FBAA(162.1,"AI",FBPSA,9999999-FBI,FBIN,FBRX)
58 K FBI,DFN,FBV,FBSDT,FBCPT,FBPSA,FBIN,FBRX,FBDT S ZTREQ="@"
59 Q
Note: See TracBrowser for help on using the repository browser.