FBAATIC.m

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 ---FBAATIC   816     printed  Mar 13, 2025@21:01:27                                                                                                                                                                                                      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