FBAAROC ;AISC/GRR-ENTER/EDIT REPORT OF CONTACT ;06JUL86
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
2 W !! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC G Q:Y<0!(X="")!(X="^") S FBDA=+Y
ENT ;
I '$D(^FBAAA(FBDA)) K DD,DO S DIC="^FBAAA(",DIC(0)="LQ",DLAYGO=161,(X,DINUM)=FBDA D FILE^DICN S FBDA=+Y
I '$D(^FBAAA(FBDA,2,0)) S ^FBAAA(FBDA,2,0)="^161.02D^^"
S DA=FBDA
I $D(DA) S DIE="^FBAAA(",DR="[FBAA REPORT OF CONTACT]" D ^DIE G 2:'$D(FBD1),2:$D(Y)'=0
I '$D(^FBAAA(FBDA,2,FBD1,0)) K DIE,DR G 2
D SITEP^FBAAUTL G:FBPOP Q S SITE=$P(FBSITE(0),"^",1),ROC=FBD1,DFN=FBDA
PRINT S DIR(0)="Y",DIR("A")="Want to print this Report of Contact",DIR("B")="NO" D ^DIR K DIR G:$D(DIRUT)!'Y 2
S VAR="DFN^ROC^SITE",VAL=DFN_"^"_ROC_"^"_SITE,PGM="START^FBAAPRC" D ZIS^FBAAUTL G 2:FBPOP
D START^FBAAPRC G 2
Q K DAT,FBDA,FBD1,D0,D1,DA,DFN,DI,DIC,DIE,DIRUT,DR,DQ,DWLW,J,X,Y,F,FBCOUNTY,FBDX,I,PGM,PI,T,VAL,VAR,Z,ZZ,ROC,SITE,DFN,FBSITE,FBDAT
D CLOSE^FBAAUTL Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAROC 1003 printed Dec 13, 2024@01:56:27 Page 2
FBAAROC ;AISC/GRR-ENTER/EDIT REPORT OF CONTACT ;06JUL86
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
2 WRITE !!
SET DIC="^DPT("
SET DIC(0)="QEAZM"
DO ^DIC
if Y<0!(X="")!(X="^")
GOTO Q
SET FBDA=+Y
ENT ;
+1 IF '$DATA(^FBAAA(FBDA))
KILL DD,DO
SET DIC="^FBAAA("
SET DIC(0)="LQ"
SET DLAYGO=161
SET (X,DINUM)=FBDA
DO FILE^DICN
SET FBDA=+Y
+2 IF '$DATA(^FBAAA(FBDA,2,0))
SET ^FBAAA(FBDA,2,0)="^161.02D^^"
+3 SET DA=FBDA
+4 IF $DATA(DA)
SET DIE="^FBAAA("
SET DR="[FBAA REPORT OF CONTACT]"
DO ^DIE
if '$DATA(FBD1)
GOTO 2
if $DATA(Y)'=0
GOTO 2
+5 IF '$DATA(^FBAAA(FBDA,2,FBD1,0))
KILL DIE,DR
GOTO 2
+6 DO SITEP^FBAAUTL
if FBPOP
GOTO Q
SET SITE=$PIECE(FBSITE(0),"^",1)
SET ROC=FBD1
SET DFN=FBDA
PRINT SET DIR(0)="Y"
SET DIR("A")="Want to print this Report of Contact"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!'Y
GOTO 2
+1 SET VAR="DFN^ROC^SITE"
SET VAL=DFN_"^"_ROC_"^"_SITE
SET PGM="START^FBAAPRC"
DO ZIS^FBAAUTL
if FBPOP
GOTO 2
+2 DO START^FBAAPRC
GOTO 2
Q KILL DAT,FBDA,FBD1,D0,D1,DA,DFN,DI,DIC,DIE,DIRUT,DR,DQ,DWLW,J,X,Y,F,FBCOUNTY,FBDX,I,PGM,PI,T,VAL,VAR,Z,ZZ,ROC,SITE,DFN,FBSITE,FBDAT
+1 DO CLOSE^FBAAUTL
QUIT
