| 1 | FBCHPRC ;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.
|
|---|
| 4 | ROC 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
|
|---|
| 5 | EN S VAR="FBIFN",VAL=FBIFN,PGM="START^FBCHPRC" D ZIS^FBAAUTL G END:FBPOP
|
|---|
| 6 | START 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
|
|---|
| 16 | END 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
|
|---|
| 18 | VEN ;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
|
|---|
| 25 | USER ;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
|
|---|
| 28 | RPTC ;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
|
|---|
| 32 | GETNAR 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
|
|---|
| 38 | DATE X ^DD("DD") Q
|
|---|
