FBAAPRC ;AISC/DMK-PRINT REPORT OF CONTACT ;08/02/88
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
D DT^DICRW,SITEP^FBAAUTL
RD S DIC="^FBAAA(",DIC(0)="AEQM" D ^DIC Q:X=""!(X="^") G:Y<0 RD S DFN=+Y G:$O(^FBAAA(DFN,2,0))'>0 NONE S DIC="^FBAAA("_DFN_",2," D ^DIC Q:Y<0 S ROC=+Y,SITE=$P(FBSITE(0),"^",1)
S VAR="DFN^ROC^SITE",VAL=DFN_"^"_ROC_"^"_SITE,PGM="START^FBAAPRC" D ZIS^FBAAUTL G:FBPOP Q
START U IO S I=ROC,(USR,VEN,J)="",FBX=$G(^FBAAA(DFN,2,I,0)),USR=$P($G(^FBAAA(DFN,2,I,100)),"^"),VEN=$P(FBX,"^",2),Y=+FBX,VENTEL=$P(FBX,"^",3) F J=1:1:6 S J(J)="" D DATE
Q:'$D(^DPT(DFN)) S NAM=$P(^(DFN,0),"^")
I $D(^DPT(DFN,.11)) F J=1:1:6 S J(J)=$P(^(.11),"^",J)
S TEL=$S($D(^DPT(DFN,.13)):$P(^DPT(DFN,.13),"^"),1:"None on File"),STAT=$S(J(5)']"":" ",$D(^DIC(5,J(5),0)):$P(^(0),"^",2),1:" ")
S FBCON=$P($G(^FBAAA(DFN,2,ROC,0)),"^",6),FBCON=$S(FBCON="T":"Telephone",FBCON="P":"Personal",1:"Unknown")
S L="|",(PI,QQ,Q)="",$P(Q,"-",80)="-",$P(QQ,"=",80)="=" W !!!,QQ,!,?40,L,"VA Office",?58,L,"SSN #",!
W ?40,L,?58,L,!,?8,">> REPORT OF CONTACT <<",?40,L,$E(SITE,1,18),?58,L,?60,$P(^DPT(DFN,0),"^",9),!,?40,L,$E(SITE,19,30),?58,L,!,Q,!,?3," Name of Veteran",?34,L,"Telephone No. of Vet.",?58,L,"Date of Contact",!
W ?34,L,?58,L,!,?3,$E(NAM,1,30),?34,L,TEL,?58,L,?61,DAT,!,Q,!,?3," Address of Veteran",?58,L,"Type of Contact",!,?3,J(1),?58,L,!,?3,J(4) I J(5)]"" W ",",STAT," ",J(6)
W ?58,L,?63,FBCON,!,Q,!,?3," Person Contacted",?58,L,"Telephone Number of",!,?58,L," Person Contacted",!,?3,VEN,?58,L,?61,VENTEL,!,Q,!,?3,"Brief statement of information requested and given",!
ALRT1 W !!! Q:'$D(^FBAAA(DFN,2,I,1,0)) K ^UTILITY($J,"W") S DIWL=10,DIWR=70,DIWF="W" S FBI=I
F FBRR=0:0 S FBRR=$O(^FBAAA(DFN,2,FBI,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP
D ^DIWW:$D(FBXX) K FBXX S I=FBI
BOT W ! S BOT=IOSL-($Y+8) F BT=1:1:BOT W !
W Q,!,?6,"Division or Section",?40,L," Executed by(signature and title)",!,?10,"FEE BASIS",?40,L," ",$$SIGBLK^FBAAPRC(USR),!,QQ,!,"VA form 119"
Q D CLOSE^FBAAUTL K DFN,DIC,Y,X,I,J,L,NAM,TEL,ROC,S,PI,FBI,FBSITE,PGM,VAL,VAR,Z,FBCON,FBRR,USR,Q,QQ,VEN,BOT,BT,SITE,STAT,VENTEL,D0,D1,DAT,DIW,DIWF,DIWL,DIWR,DIWT,DIYS,DWLW,FBX Q
DATE S DAT=$P(FBX,"^"),DAT=$$DATX^FBAAUTL(DAT) Q
NONE W !!,"There are no Reports of Contact on line for this patient.",!! G Q
;
SIGBLK(X) ;returns the signature block printed name if in 200
;if not will return the .01 field.
;if entry does not exist will return null
;X equal to duz
;
I $S('$G(X):1,'$D(^VA(200,X,0)):1,1:0) Q ""
Q $S($P($G(^VA(200,X,20)),U,2)]"":$P(^(20),U,2),1:$P(^VA(200,X,0),U))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAPRC 2657 printed Dec 13, 2024@01:56:16 Page 2
FBAAPRC ;AISC/DMK-PRINT REPORT OF CONTACT ;08/02/88
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO DT^DICRW
DO SITEP^FBAAUTL
RD SET DIC="^FBAAA("
SET DIC(0)="AEQM"
DO ^DIC
if X=""!(X="^")
QUIT
if Y<0
GOTO RD
SET DFN=+Y
if $ORDER(^FBAAA(DFN,2,0))'>0
GOTO NONE
SET DIC="^FBAAA("_DFN_",2,"
DO ^DIC
if Y<0
QUIT
SET ROC=+Y
SET SITE=$PIECE(FBSITE(0),"^",1)
+1 SET VAR="DFN^ROC^SITE"
SET VAL=DFN_"^"_ROC_"^"_SITE
SET PGM="START^FBAAPRC"
DO ZIS^FBAAUTL
if FBPOP
GOTO Q
START USE IO
SET I=ROC
SET (USR,VEN,J)=""
SET FBX=$GET(^FBAAA(DFN,2,I,0))
SET USR=$PIECE($GET(^FBAAA(DFN,2,I,100)),"^")
SET VEN=$PIECE(FBX,"^",2)
SET Y=+FBX
SET VENTEL=$PIECE(FBX,"^",3)
FOR J=1:1:6
SET J(J)=""
DO DATE
+1 if '$DATA(^DPT(DFN))
QUIT
SET NAM=$PIECE(^(DFN,0),"^")
+2 IF $DATA(^DPT(DFN,.11))
FOR J=1:1:6
SET J(J)=$PIECE(^(.11),"^",J)
+3 SET TEL=$SELECT($DATA(^DPT(DFN,.13)):$PIECE(^DPT(DFN,.13),"^"),1:"None on File")
SET STAT=$SELECT(J(5)']"":" ",$DATA(^DIC(5,J(5),0)):$PIECE(^(0),"^",2),1:" ")
+4 SET FBCON=$PIECE($GET(^FBAAA(DFN,2,ROC,0)),"^",6)
SET FBCON=$SELECT(FBCON="T":"Telephone",FBCON="P":"Personal",1:"Unknown")
+5 SET L="|"
SET (PI,QQ,Q)=""
SET $PIECE(Q,"-",80)="-"
SET $PIECE(QQ,"=",80)="="
WRITE !!!,QQ,!,?40,L,"VA Office",?58,L,"SSN #",!
+6 WRITE ?40,L,?58,L,!,?8,">> REPORT OF CONTACT <<",?40,L,$EXTRACT(SITE,1,18),?58,L,?60,$PIECE(^DPT(DFN,0),"^",9),!,?40,L,$EXTRACT(SITE,19,30),?58,L,!,Q,!,?3," Name of Veteran",?34,L,"Telephone No. of Vet.",?58,L,"Date of Contact",!
+7 WRITE ?34,L,?58,L,!,?3,$EXTRACT(NAM,1,30),?34,L,TEL,?58,L,?61,DAT,!,Q,!,?3," Address of Veteran",?58,L,"Type of Contact",!,?3,J(1),?58,L,!,?3,J(4)
IF J(5)]""
WRITE ",",STAT," ",J(6)
+8 WRITE ?58,L,?63,FBCON,!,Q,!,?3," Person Contacted",?58,L,"Telephone Number of",!,?58,L," Person Contacted",!,?3,VEN,?58,L,?61,VENTEL,!,Q,!,?3,"Brief statement of information requested and given",!
ALRT1 WRITE !!!
if '$DATA(^FBAAA(DFN,2,I,1,0))
QUIT
KILL ^UTILITY($JOB,"W")
SET DIWL=10
SET DIWR=70
SET DIWF="W"
SET FBI=I
+1 FOR FBRR=0:0
SET FBRR=$ORDER(^FBAAA(DFN,2,FBI,1,FBRR))
if FBRR'>0
QUIT
SET FBXX=^(FBRR,0)
SET X=FBXX
DO ^DIWP
+2 if $DATA(FBXX)
DO ^DIWW
KILL FBXX
SET I=FBI
BOT WRITE !
SET BOT=IOSL-($Y+8)
FOR BT=1:1:BOT
WRITE !
+1 WRITE Q,!,?6,"Division or Section",?40,L," Executed by(signature and title)",!,?10,"FEE BASIS",?40,L," ",$$SIGBLK^FBAAPRC(USR),!,QQ,!,"VA form 119"
Q DO CLOSE^FBAAUTL
KILL DFN,DIC,Y,X,I,J,L,NAM,TEL,ROC,S,PI,FBI,FBSITE,PGM,VAL,VAR,Z,FBCON,FBRR,USR,Q,QQ,VEN,BOT,BT,SITE,STAT,VENTEL,D0,D1,DAT,DIW,DIWF,DIWL,DIWR,DIWT,DIYS,DWLW,FBX
QUIT
DATE SET DAT=$PIECE(FBX,"^")
SET DAT=$$DATX^FBAAUTL(DAT)
QUIT
NONE WRITE !!,"There are no Reports of Contact on line for this patient.",!!
GOTO Q
+1 ;
SIGBLK(X) ;returns the signature block printed name if in 200
+1 ;if not will return the .01 field.
+2 ;if entry does not exist will return null
+3 ;X equal to duz
+4 ;
+5 IF $SELECT('$GET(X):1,'$DATA(^VA(200,X,0)):1,1:0)
QUIT ""
+6 QUIT $SELECT($PIECE($GET(^VA(200,X,20)),U,2)]"":$PIECE(^(20),U,2),1:$PIECE(^VA(200,X,0),U))
