source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAVD2.m@ 1361

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

initial load of WorldVistAEHR
File size: 5.3 KB
RevLine 
[613]1FBAAVD2 ;AISC/DMK-EDIT VENDOR DEMOGRAPHICS ;07/17/06
2 ;;3.5;FEE BASIS;**9,10,47,65,98**;JAN 30, 1995;Build 54
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4EDITV ;entry to edit vendor demographic data
5 ;DA defined to IEN of vendor file (161.2)
6 Q:'$G(DA) N FBADT,FBDA,Z6 S FBDA=DA L +^FBAAV(DA):1 I '$T W !,"Unable to access vendor record. Trying again.",! G EDITV
7 S FBT=$S($D(FBT):FBT,1:""),FBT=$S(FBT="N":FBT,1:"C")
8 S FEEO="",DIE="^FBAAV(",DR="[FBAA EDIT VENDOR]",DIE("NO^")="BACKOUTOK"
9 S Z1=$G(^FBAAV(DA,0)),Z3=$G(^(1)),Z4=$G(^("AMS")),Z5=$G(^("ADEL")),Z6=$P($G(^(3)),U,2)
10 D GETGRP^FBAAUTL6(DA)
11 D ^DIE
12 I $P($G(^FBAAV(DA,0)),"^",13)']"" S DR="3;4;5;5.5",DIE("NO^")="" D ^DIE
13 K DIE
14 L -^FBAAV(DA)
15 ;check if data was changed
16 I $D(^FBAAV(DA,0)),(($P(Z1,U,2,6)'=$P(^FBAAV(DA,0),U,2,6))!($P(Z1,U,8,16)'=$P(^FBAAV(DA,0),U,8,16))!($P(Z3,U,10)'=$P($G(^FBAAV(DA,1)),U,10))!$$GRPDIF^FBAAUTL6(DA))!($P($G(^FBAAV(DA,3)),U,2))'=Z6 D
17 .S FBVNAME=$P(^FBAAV(DA,0),U),FBIEN1=DA,FBADT=$P(Z5,U,4),FBNPI=$P($G(^FBAAV(FBIEN1,3)),U,2)
18 .;check if date last received from austin, version 3. If so, then did not receive in upload - send update instead of change
19 .;fbadt = date received from austin.
20 .I '$$CKVEN^FBAADV(DA),FBADT']"" D UPDT^FBAAAV(FBDA) Q ;,FBADT<FBINSTAL D UPDT^FBAAAV(DA) Q
21 .;if austin deleted is yes, send update instead of change
22 .I $P($G(^FBAAV(FBDA,"ADEL")),"^")="Y" D UPDT^FBAAAV(FBDA) Q
23 .;if editing a newly added vendor, send update instead of change
24 .I FBT="N" D UPDT^FBAAAV(FBDA) Q
25 .;if only FPDS data was changed
26 .I $P(Z1,U,2,6)=$P(^FBAAV(DA,0),U,2,6),$P(Z1,U,8,16)=$P(^FBAAV(DA,0),U,8,16) D Q:FBT=""
27 ..I '$D(^FBAA(161.25,"AF",DA)),'$D(^FBAA(161.25,DA,0)) S FBT="F" Q ; no pending actions - add "F"
28 ..I '$D(^FBAA(161.25,"AF",DA)),$D(^FBAA(161.25,DA,0)),$P(^(0),U,5)="" S FBT="" Q ; action pending, but not yet transmitted - will incl. FPDS data
29 .I FBT="F" S FBIEN1=DA,FEEO="" D SETGL^FBAAVD Q ; send FEE-ONLY
30 .;If date from austin not null then add vendor entry for a change
31 .K DD,DO S DIC="^FBAAV(",DIC(0)="L",DLAYGO=161.2,X=FBVNAME D FILE^DICN Q:Y<0 S FBIEN=+Y
32 .L +^FBAAV(FBIEN)
33 .S ^FBAAV(FBIEN,0)=$G(^FBAAV(FBIEN1,0))
34 .S ^FBAAV(FBIEN,1)=$G(^FBAAV(FBIEN1,1))
35 .S ^FBAAV(FBIEN,"AMS")=$G(^FBAAV(FBIEN1,"AMS")),$P(^FBAAV(FBIEN,"AMS"),"^")=""
36 .K FBFDA
37 .S I=0 F S I=$O(^FBAAV(FBIEN1,2,I)) Q:'I D
38 ..S X=$P($G(^(I,0)),U) I X]"" S FBFDA(161.225,"+"_I_","_FBIEN_",",.01)=X
39 .I $D(FBFDA) D UPDATE^DIE("","FBFDA")
40 .S DIK="^FBAAV(",DA=FBIEN D IX1^DIK
41 .L -^FBAAV(FBIEN)
42 .;restore original vendor data
43 .L +^FBAAV(FBIEN1)
44 .S DIE="^FBAAV(",DA=FBIEN1,DR="[FB VENDOR UPDATE]" D ^DIE K DIE
45 .D UPDGRP^FBAAUTL6(FBIEN1)
46 .L -^FBAAV(FBIEN1)
47 .S DA=FBIEN D SETGL^FBAAVD
48 K FBSG,FBVNAME,FBIEN,FBIEN1,Z3,Z4,Z5
49 ;
50CONTR ;enter contract information for a CNH vendor
51 Q:$S('$D(FBPARCD):1,FBPARCD'=5:1,1:0)
52 Q:'$G(DA) S FBVIEN=DA
53 S FBLIEN=$P($G(^FBAA(161.25,FBVIEN,0)),"^",6) I FBLIEN]"",FBLIEN'=FBVIEN W !!,*7,"Cannot add contract information to this vendor until change has been",!,"approved by Austin." Q
54 W ! S DIC="^FBAA(161.21,",DIC(0)="AEQLM",DLAYGO=161.21,DIC("S")="I $P(^(0),U,4)="_FBVIEN
55 D ^DIC K DIC,DLAYGO Q:X=""!(X="^") G CONTR:Y<0
56 S DA=+Y,FBCNUM=$P(Y,"^",2),DIE="^FBAA(161.21," L +^FBAA(161.21,DA)
57 S ZO1=^FBAA(161.21,DA,0),DR="[FBNH ENTER CONTRACT]",DIE("NO^")="" D ^DIE K DIE,DR
58 I '$G(DA) K ZO1 Q
59 I $D(^FBAA(161.22,"AC",DA)) D
60 .Q:$P(ZO1,"^",1,2)=$P(^FBAA(161.21,DA,0),"^",1,2) W !!,*7,"You cannot change contract numbers or effective dates on",!,"a contract that has rates associated with it."
61 .S DIE="^FBAA(161.21,",DR=".01////^S X=$P(ZO1,U);.02////^S X=$P(ZO1,U,2);.03////^S X=$P(ZO1,U,3);.04////^S X=$P(ZO1,U,4)" D ^DIE K DIE,DR W !!,"Contract information reset"
62 L -^FBAA(161.21,DA) K ZO1
63 Q:$D(DTOUT)
64 I $G(FBEXNDT)<$G(FBEXDT) D URATE K FBCIEN,FBEXDT,FBEXNDT,FBURT
65 ;create rates for a contract. Rates cannot be changed, but the
66 ;user can enter multiple rates for a contract.
67 ;FBCIEN=internal entry number for contract in 161.21
68 S FBCIEN=DA K FBX
69RATE K DA W ! S DIR(0)="161.22,.02",DIR("A")="Enter Nursing Home Rate",DIR("?")="^K FBX,FBRATE D DISPLAY^FBAAVD1 W !,""Enter an amount between .01 and 9999999.99""" D ^DIR
70 K DIR Q:$D(DIRUT) Q:'Y S FBR=+Y
71 I $L($$RATE^FBAAVD1($P(^FBAA(161.21,FBCIEN,0),"^",1)))+$L("^"_FBR)>510 W !,*7,"There are too many rates loaded for that contract! Please remove obsolete rates.",! Q
72 I $D(^FBAA(161.22,"AD",FBCIEN,FBR)) K FBR W !,*7,"Rate already exists for that contract!",! G RATE
73 S X=$P(^FBAA(161.22,0),U,3)
74RETRY S X=X+1 G:$D(^FBAA(161.22,X)) RETRY
75 L +^FBAA(161.22,X)
76 K DD,DO S DIC="^FBAA(161.22,",DIC(0)="L",DLAYGO=161.22,DIC("DR")=".02////^S X="_FBR_";.03////^S X="_FBCIEN D FILE^DICN K DIC,DLAYGO
77 L -^FBAA(161.22,+Y)
78 G RATE
79 ;
80GETVEN K FBRATE D GETVEN^FBAAUTL1 G END:'IFN
81 S DA=IFN K DIC,IFN
82 S FBPARCD=$P($G(^FBAAV(DA,0)),U,9)
83 I FBPARCD'=5 W !?5,*7,"Vendor selected is not a Community Nursing Home.",! G GETVEN
84 D CONTR G GETVEN
85END K DIC,DA,FBVIEN,IFN,FBPARCD,X,Y,FBLIEN
86 Q
87URATE ;Update rate when user backs up contract dates.
88 N DA S (FBCIEN,FBURT)=0
89 F S FBURT=$O(^FBAA(161.23,"AE",FBCNUM,FBURT)) Q:'FBURT F S FBCIEN=$O(^FBAA(161.23,"AE",FBCNUM,FBURT,FBCIEN)) Q:'FBCIEN I $P($G(^FBAA(161.23,FBCIEN,0)),"^",2)>FBEXNDT D
90 .I +$G(^FBAA(161.23,FBCIEN,0))>FBEXNDT S DIK="^FBAA(161.23,",DA=FBCIEN D ^DIK K DIK Q
91 .S DIE="^FBAA(161.23,",DA=FBCIEN,DR=".02////^S X=FBEXNDT" D ^DIE K DIE
92 Q
Note: See TracBrowser for help on using the repository browser.