FBAATIC ;AISC/CMR-TERMINATE ID CARD ;15 APR 1993
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
D SITEP^FBAAUTL G Q:FBPOP S FBPROG="I $P(^(0),U,3)=2"
RD W ! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC K DIC G Q:Y<0 S DFN=+Y
I $P($G(^FBAAA(DFN,4)),"^")']"" W !!,"There is no FEE ID Card information on file for this patient!" G Q
D ^FBAADEM
S HID=$P(^FBAAA(DFN,4),"^"),NIDR=$P(^(4),"^",3) W !!,"Fee ID Card #: ",HID,!
S DIR(0)="Y",DIR("A")="Are you sure you want to terminate this ID Card",DIR("B")="No" D ^DIR K DIR G Q:$D(DIRUT),RD:'Y
S DA=DFN,DIE="^FBAAA(",DR=".5////^S X=""@"";.65///^S X=""T"";.7TERMINATION REASON~;S NIDR=X",DIE("NO^")="" D ^DIE K DIE
D TRIG^FBAAAUT
G RD
Q K Y,DFN,FBPOP,HID,NIDR,DA,FBSITE,X,FBAAOUT,DR,FBAUT,FBPROG,TIME,NID
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAATIC 816 printed Nov 22, 2024@17:06:55 Page 2
FBAATIC ;AISC/CMR-TERMINATE ID CARD ;15 APR 1993
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO SITEP^FBAAUTL
if FBPOP
GOTO Q
SET FBPROG="I $P(^(0),U,3)=2"
RD WRITE !
SET DIC="^DPT("
SET DIC(0)="QEAZM"
DO ^DIC
KILL DIC
if Y<0
GOTO Q
SET DFN=+Y
+1 IF $PIECE($GET(^FBAAA(DFN,4)),"^")']""
WRITE !!,"There is no FEE ID Card information on file for this patient!"
GOTO Q
+2 DO ^FBAADEM
+3 SET HID=$PIECE(^FBAAA(DFN,4),"^")
SET NIDR=$PIECE(^(4),"^",3)
WRITE !!,"Fee ID Card #: ",HID,!
+4 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to terminate this ID Card"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO Q
if 'Y
GOTO RD
+5 SET DA=DFN
SET DIE="^FBAAA("
SET DR=".5////^S X=""@"";.65///^S X=""T"";.7TERMINATION REASON~;S NIDR=X"
SET DIE("NO^")=""
DO ^DIE
KILL DIE
+6 DO TRIG^FBAAAUT
+7 GOTO RD
Q KILL Y,DFN,FBPOP,HID,NIDR,DA,FBSITE,X,FBAAOUT,DR,FBAUT,FBPROG,TIME,NID
+1 QUIT
