source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCHPRC.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: 2.3 KB
RevLine 
[613]1FBCHPRC ;AISC/DMK-PRINT ROC FOR CONTRACT HOSPITAL ;15AUG90
2 ;;3.5;FEE BASIS;;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4ROC S DIC="^FBAA(161.5,",DIC(0)="AEQM",D="D",DIC("A")="Select Veteran: ",DIC("W")="W ?30,$S($D(^FBAAV($P(^(0),U,2),0)):$P(^(0),U),1:"""")" D IX^DIC K D,DIC G END:X=""!(X="^"),ROC:Y<0 S FBIFN=+Y
5EN S VAR="FBIFN",VAL=FBIFN,PGM="START^FBCHPRC" D ZIS^FBAAUTL G END:FBPOP
6START U IO W:$E(IOST,1,2)["C-" @IOF S L="|",Q="",$P(Q,"-",80)="-",FB("PG")=1
7 G END:'$D(^FBAA(161.5,FBIFN,0)) S FB(0)=^(0),FB1(0)="" I $D(^FBAA(161.5,FBIFN,1)) S FB1(0)=^(1)
8 F J=1:1:14 S FB(J)=$P(FB(0),"^",J)
9 F I=1:1:4 S FB(J+I)=$P(FB1(0),"^",I)
10 S FB(J+5)=$P(FB1(0),"^",7)
11 S DFN=FB(3),VAPA("P")="" D 6^VADPT,SITEP^FBAAUTL S FBSITE=$P(FBSITE(0),"^"),Y=FB(4) D DATE S FB(4)=$E(Y,1,17)
12 S FB(17)=$S(FB(17)="":"Unknown",$D(^DGBT(392.4,FB(17),0)):$P(^(0),"^"),1:"Unknown")
13 I FB(5)]"" S FB(5)=$$DATX^FBAAUTL(FB(5))
14 I FB(19)]"" S FB(19)=$$DATX^FBAAUTL(FB(19))
15 D VEN,^FBCHPRC1
16END K DIWF,DIWL,BT,BOT,DIWR,DFN,FB1,FB,FBI,FBIFN,FBRR,FBSITE,FBVEN,I,J,L,PGM,Q,VA,VADM,VAEL,VAERR,VAL,VAR,VAPA,X,Y,Z D CLOSE^FBAAUTL
17 Q
18VEN ;GET VENDOR DEMOGRAPHICS
19 S FBVEN(0)=$S(FB(2)="":"",$D(^FBAAV(FB(2),0)):^(0),1:"") I FBVEN(0)="" S FBVEN="Unknown" Q
20 S FBVEN(6)=$S($D(^FBAAV(FB(2),1)):$P(^(1),"^"),1:""),FBVEN=$P(FBVEN(0),"^")
21 S FBVEN(1)=$P(FBVEN(0),"^",3),FBVEN(2)=$P(FBVEN(0),"^",14),FBVEN(3)=$P(FBVEN(0),"^",4)
22 S FBVEN(4)=$S($P(FBVEN(0),"^",5)']"":"Unknown",$D(^DIC(5,$P(FBVEN(0),"^",5),0)):$P(^(0),"^"),1:"Unknown")
23 S FBVEN(5)=$P(FBVEN(0),"^",6)
24 K FBVEN(0) Q
25USER ;GET USER IN FILE 200
26 S FB("USER")=$S(FB("DUZ")="":"Unknown",$D(^VA(200,FB("DUZ"),0)):$P(^(0),"^"),1:"Unknown")
27 Q
28RPTC ;RETRIEVE DATE,USER AND NARRATIVE OF ROC
29 S DIWL=7,DIWR=74,DIWF="W"
30 F FBI=0:0 S FBI=$O(^FBAA(161.5,FBIFN,2,FBI)) Q:FBI'>0 I $D(^FBAA(161.5,FBIFN,2,FBI,0)) S FB("DATE")=$P(^(0),"^"),FB("DUZ")=$P(^(0),"^",2) D GETNAR
31 Q
32GETNAR K ^UTILITY($J,"W") S Y=FB("DATE") D DATE S FB("DATE")=Y D USER
33 W !,"DATE: ",FB("DATE"),?53,"USER: ",$E(FB("USER"),1,22)
34 F FBRR=0:0 S FBRR=$O(^FBAA(161.5,FBIFN,2,FBI,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP
35 D ^DIWW:$D(FBXX) K FBXX
36 I $Y+11>IOSL S FB("PG")=FB("PG")+1 W @IOF,!,?70,"Page ",FB("PG"),!!?25,"REPORT OF CONTACT CONTINUED",!,?24,$E(Q,1,29),!,?1,"For: ",VADM(1),!,Q,!
37 Q
38DATE X ^DD("DD") Q
Note: See TracBrowser for help on using the repository browser.