- 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 Mar 13, 2025@21:02:33 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
