FBCHPRC ;AISC/DMK-PRINT ROC FOR CONTRACT HOSPITAL ;15AUG90
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
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
EN S VAR="FBIFN",VAL=FBIFN,PGM="START^FBCHPRC" D ZIS^FBAAUTL G END:FBPOP
START U IO W:$E(IOST,1,2)["C-" @IOF S L="|",Q="",$P(Q,"-",80)="-",FB("PG")=1
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)
F J=1:1:14 S FB(J)=$P(FB(0),"^",J)
F I=1:1:4 S FB(J+I)=$P(FB1(0),"^",I)
S FB(J+5)=$P(FB1(0),"^",7)
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)
S FB(17)=$S(FB(17)="":"Unknown",$D(^DGBT(392.4,FB(17),0)):$P(^(0),"^"),1:"Unknown")
I FB(5)]"" S FB(5)=$$DATX^FBAAUTL(FB(5))
I FB(19)]"" S FB(19)=$$DATX^FBAAUTL(FB(19))
D VEN,^FBCHPRC1
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
Q
VEN ;GET VENDOR DEMOGRAPHICS
S FBVEN(0)=$S(FB(2)="":"",$D(^FBAAV(FB(2),0)):^(0),1:"") I FBVEN(0)="" S FBVEN="Unknown" Q
S FBVEN(6)=$S($D(^FBAAV(FB(2),1)):$P(^(1),"^"),1:""),FBVEN=$P(FBVEN(0),"^")
S FBVEN(1)=$P(FBVEN(0),"^",3),FBVEN(2)=$P(FBVEN(0),"^",14),FBVEN(3)=$P(FBVEN(0),"^",4)
S FBVEN(4)=$S($P(FBVEN(0),"^",5)']"":"Unknown",$D(^DIC(5,$P(FBVEN(0),"^",5),0)):$P(^(0),"^"),1:"Unknown")
S FBVEN(5)=$P(FBVEN(0),"^",6)
K FBVEN(0) Q
USER ;GET USER IN FILE 200
S FB("USER")=$S(FB("DUZ")="":"Unknown",$D(^VA(200,FB("DUZ"),0)):$P(^(0),"^"),1:"Unknown")
Q
RPTC ;RETRIEVE DATE,USER AND NARRATIVE OF ROC
S DIWL=7,DIWR=74,DIWF="W"
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
Q
GETNAR K ^UTILITY($J,"W") S Y=FB("DATE") D DATE S FB("DATE")=Y D USER
W !,"DATE: ",FB("DATE"),?53,"USER: ",$E(FB("USER"),1,22)
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
D ^DIWW:$D(FBXX) K FBXX
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,!
Q
DATE X ^DD("DD") Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHPRC 2379 printed Sep 23, 2025@19:33:52 Page 2
FBCHPRC ;AISC/DMK-PRINT ROC FOR CONTRACT HOSPITAL ;15AUG90
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
ROC SET DIC="^FBAA(161.5,"
SET DIC(0)="AEQM"
SET D="D"
SET DIC("A")="Select Veteran: "
SET DIC("W")="W ?30,$S($D(^FBAAV($P(^(0),U,2),0)):$P(^(0),U),1:"""")"
DO IX^DIC
KILL D,DIC
if X=""!(X="^")
GOTO END
if Y<0
GOTO ROC
SET FBIFN=+Y
EN SET VAR="FBIFN"
SET VAL=FBIFN
SET PGM="START^FBCHPRC"
DO ZIS^FBAAUTL
if FBPOP
GOTO END
START USE IO
if $EXTRACT(IOST,1,2)["C-"
WRITE @IOF
SET L="|"
SET Q=""
SET $PIECE(Q,"-",80)="-"
SET FB("PG")=1
+1 if '$DATA(^FBAA(161.5,FBIFN,0))
GOTO END
SET FB(0)=^(0)
SET FB1(0)=""
IF $DATA(^FBAA(161.5,FBIFN,1))
SET FB1(0)=^(1)
+2 FOR J=1:1:14
SET FB(J)=$PIECE(FB(0),"^",J)
+3 FOR I=1:1:4
SET FB(J+I)=$PIECE(FB1(0),"^",I)
+4 SET FB(J+5)=$PIECE(FB1(0),"^",7)
+5 SET DFN=FB(3)
SET VAPA("P")=""
DO 6^VADPT
DO SITEP^FBAAUTL
SET FBSITE=$PIECE(FBSITE(0),"^")
SET Y=FB(4)
DO DATE
SET FB(4)=$EXTRACT(Y,1,17)
+6 SET FB(17)=$SELECT(FB(17)="":"Unknown",$DATA(^DGBT(392.4,FB(17),0)):$PIECE(^(0),"^"),1:"Unknown")
+7 IF FB(5)]""
SET FB(5)=$$DATX^FBAAUTL(FB(5))
+8 IF FB(19)]""
SET FB(19)=$$DATX^FBAAUTL(FB(19))
+9 DO VEN
DO ^FBCHPRC1
END KILL 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
DO CLOSE^FBAAUTL
+1 QUIT
VEN ;GET VENDOR DEMOGRAPHICS
+1 SET FBVEN(0)=$SELECT(FB(2)="":"",$DATA(^FBAAV(FB(2),0)):^(0),1:"")
IF FBVEN(0)=""
SET FBVEN="Unknown"
QUIT
+2 SET FBVEN(6)=$SELECT($DATA(^FBAAV(FB(2),1)):$PIECE(^(1),"^"),1:"")
SET FBVEN=$PIECE(FBVEN(0),"^")
+3 SET FBVEN(1)=$PIECE(FBVEN(0),"^",3)
SET FBVEN(2)=$PIECE(FBVEN(0),"^",14)
SET FBVEN(3)=$PIECE(FBVEN(0),"^",4)
+4 SET FBVEN(4)=$SELECT($PIECE(FBVEN(0),"^",5)']"":"Unknown",$DATA(^DIC(5,$PIECE(FBVEN(0),"^",5),0)):$PIECE(^(0),"^"),1:"Unknown")
+5 SET FBVEN(5)=$PIECE(FBVEN(0),"^",6)
+6 KILL FBVEN(0)
QUIT
USER ;GET USER IN FILE 200
+1 SET FB("USER")=$SELECT(FB("DUZ")="":"Unknown",$DATA(^VA(200,FB("DUZ"),0)):$PIECE(^(0),"^"),1:"Unknown")
+2 QUIT
RPTC ;RETRIEVE DATE,USER AND NARRATIVE OF ROC
+1 SET DIWL=7
SET DIWR=74
SET DIWF="W"
+2 FOR FBI=0:0
SET FBI=$ORDER(^FBAA(161.5,FBIFN,2,FBI))
if FBI'>0
QUIT
IF $DATA(^FBAA(161.5,FBIFN,2,FBI,0))
SET FB("DATE")=$PIECE(^(0),"^")
SET FB("DUZ")=$PIECE(^(0),"^",2)
DO GETNAR
+3 QUIT
GETNAR KILL ^UTILITY($JOB,"W")
SET Y=FB("DATE")
DO DATE
SET FB("DATE")=Y
DO USER
+1 WRITE !,"DATE: ",FB("DATE"),?53,"USER: ",$EXTRACT(FB("USER"),1,22)
+2 FOR FBRR=0:0
SET FBRR=$ORDER(^FBAA(161.5,FBIFN,2,FBI,1,FBRR))
if FBRR'>0
QUIT
SET FBXX=^(FBRR,0)
SET X=FBXX
DO ^DIWP
+3 if $DATA(FBXX)
DO ^DIWW
KILL FBXX
+4 IF $Y+11>IOSL
SET FB("PG")=FB("PG")+1
WRITE @IOF,!,?70,"Page ",FB("PG"),!!?25,"REPORT OF CONTACT CONTINUED",!,?24,$EXTRACT(Q,1,29),!,?1,"For: ",VADM(1),!,Q,!
+5 QUIT
DATE XECUTE ^DD("DD")
QUIT
