- FBCHROC ;AISC/DMK-REPORT OF CONTACT FOR CONTRACT HOSPITAL ;13AUG90
- ;;3.5;FEE BASIS;;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- I '$D(FBDA),'$D(FBVD),'$D(FBDATE),'$D(DFN),'$D(DUZ),'$D(FBADDT),'$D(FBPHY),'$D(FBDIAG) Q
- W ! K DD,DO S DIC="^FBAA(161.5,",DIC(0)="L",DLAYGO=161.5,(X,DINUM)=FBDA D FILE^DICN K DLAYGO S DA=+Y,FBDATE=$E(FBDATE,1,12)
- I '$D(^FBAA(161.5,FBDA,2,0)) S ^FBAA(161.5,FBDA,2,0)="^161.517D^^"
- S DIE=DIC,DR="[FBCH ENTER ROC]" D ^DIE K DIC,DIE
- S DA(1)=FBDA,DIC="^FBAA(161.5,"_FBDA_",2,",DIC(0)="L",DLAYGO=161.5,X=FBDATE D ^DIC K DIC Q:Y<0 S DA=+Y,DA(1)=FBDA
- S DIE="^FBAA(161.5,"_DA(1)_",2,",DR=".01////^S X=FBDATE;2////^S X=DUZ;1" D ^DIE K DIE
- END K FBVD,FBDATE,FBADDT,FBPHY,FBDIAG,DIC,DIE,DR,DA Q
- ;
- ADD W !! S DIC="^FBAA(161.5,",DIC(0)="AEQM",D="D",DIC("A")="Select Veteran: " D IX^DIC K D,DIC("A") G END:X=""!(X="^")
- S FBDA=+Y
- S DIE="^FBAA(161.5,",DA=FBDA,DR="[FBCH ADD ROC]" D ^DIE
- K DIC,DIE,FBDA G ADD
- ;
- EDIT W !! S DIC="^FBAA(161.5,",DIC(0)="AEQM",D="D",DIC("A")="Select Veteran: " D IX^DIC K D,DIC("A") G END:X=""!(X="^") S DA=+Y
- EN S DIE=DIC,DR="[FBCH EDIT ROC]" D ^DIE
- Q:$D(FBREQED)
- K DIC,DIE,DA,X,Y G EDIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHROC 1201 printed Mar 13, 2025@21:02:50 Page 2
- FBCHROC ;AISC/DMK-REPORT OF CONTACT FOR CONTRACT HOSPITAL ;13AUG90
- +1 ;;3.5;FEE BASIS;;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 IF '$DATA(FBDA)
- IF '$DATA(FBVD)
- IF '$DATA(FBDATE)
- IF '$DATA(DFN)
- IF '$DATA(DUZ)
- IF '$DATA(FBADDT)
- IF '$DATA(FBPHY)
- IF '$DATA(FBDIAG)
- QUIT
- +4 WRITE !
- KILL DD,DO
- SET DIC="^FBAA(161.5,"
- SET DIC(0)="L"
- SET DLAYGO=161.5
- SET (X,DINUM)=FBDA
- DO FILE^DICN
- KILL DLAYGO
- SET DA=+Y
- SET FBDATE=$EXTRACT(FBDATE,1,12)
- +5 IF '$DATA(^FBAA(161.5,FBDA,2,0))
- SET ^FBAA(161.5,FBDA,2,0)="^161.517D^^"
- +6 SET DIE=DIC
- SET DR="[FBCH ENTER ROC]"
- DO ^DIE
- KILL DIC,DIE
- +7 SET DA(1)=FBDA
- SET DIC="^FBAA(161.5,"_FBDA_",2,"
- SET DIC(0)="L"
- SET DLAYGO=161.5
- SET X=FBDATE
- DO ^DIC
- KILL DIC
- if Y<0
- QUIT
- SET DA=+Y
- SET DA(1)=FBDA
- +8 SET DIE="^FBAA(161.5,"_DA(1)_",2,"
- SET DR=".01////^S X=FBDATE;2////^S X=DUZ;1"
- DO ^DIE
- KILL DIE
- END KILL FBVD,FBDATE,FBADDT,FBPHY,FBDIAG,DIC,DIE,DR,DA
- QUIT
- +1 ;
- ADD WRITE !!
- SET DIC="^FBAA(161.5,"
- SET DIC(0)="AEQM"
- SET D="D"
- SET DIC("A")="Select Veteran: "
- DO IX^DIC
- KILL D,DIC("A")
- if X=""!(X="^")
- GOTO END
- +1 SET FBDA=+Y
- +2 SET DIE="^FBAA(161.5,"
- SET DA=FBDA
- SET DR="[FBCH ADD ROC]"
- DO ^DIE
- +3 KILL DIC,DIE,FBDA
- GOTO ADD
- +4 ;
- EDIT WRITE !!
- SET DIC="^FBAA(161.5,"
- SET DIC(0)="AEQM"
- SET D="D"
- SET DIC("A")="Select Veteran: "
- DO IX^DIC
- KILL D,DIC("A")
- if X=""!(X="^")
- GOTO END
- SET DA=+Y
- EN SET DIE=DIC
- SET DR="[FBCH EDIT ROC]"
- DO ^DIE
- +1 if $DATA(FBREQED)
- QUIT
- +2 KILL DIC,DIE,DA,X,Y
- GOTO EDIT
