FBAACH ;AISC/GRR-DISPLAY ID CARD HISTORY FOR PATIENT ;13APR86
;;3.5;FEE BASIS;;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP S UL="" F A=1:1:79 S UL=UL_"="
RD K FBOUT W !! S DIC="^FBAAA(",DIC(0)="AEQM" D ^DIC G Q:X="^"!(X=""),RD:Y<0 S DFN=+Y
I '$D(^FBAAA(DFN,4)),'$D(^FBAA(161.83,DFN)) W !!,"Patient has never been assigned ID Card!" G RD
S FBNM=$S($D(^DPT(DFN,0)):$P(^(0),"^"),1:""),FBSSN=$$SSN^FBAAUTL(DFN)
I '$D(^FBAAA(DFN,4)),$D(^FBAA(161.83,DFN)) D HED,NOC,HED2,LISTH G RD
S Y(0)=^FBAAA(DFN,4),FBIDC=$P(Y(0),"^",1),FBDT=$P(Y(0),"^",2)
D HED W !,?6,"Current ID Card: ",FBIDC,?32,"Date Issued: ",$E(FBDT,4,5),"/",$E(FBDT,6,7),"/",$E(FBDT,2,3)
I $D(^FBAA(161.83,DFN)) D HED2,LISTH G RD
W !!,?5,"No previous ID Cards!",! G RD
HED W @IOF,"Patient: ",FBNM,?41,"SSN: ",FBSSN,! Q
NOC W !,"Does not currently have ID Card!",! Q
HED2 W !!,"Date/Time Changed",?22,"Old Card #",?35,"Person Who Changed",!,?5,"Reason For Change",!,UL Q
LISTH I $D(^FBAA(161.83,DFN,1)) F J=0:0 S J=$O(^FBAA(161.83,DFN,1,J)) Q:J'>0 I $D(^(J,0)) S Y(0)=^(0) D GOT Q:$G(FBOUT)
Q
GOT S FBDT=$P(Y(0),"^"),FBIDC=$P(Y(0),"^",2),FBR=$P(Y(0),"^",3),FBUSER=$P(Y(0),"^",4)
S X=FBDT D TM^FBAAUTL S Y=FBDT D PDF^FBAAUTL S FBUSER=$S(FBUSER="":"UNKNOWN",$D(^VA(200,FBUSER,0)):$P(^(0),"^",1),1:"UNKNOWN")
I $Y+2>IOSL S DIR(0)="E" D ^DIR K DIR S:$D(DIRUT) FBOUT=1 Q:$G(FBOUT) D HED,HED2
W !,Y,?10,$J(X,8),?23,FBIDC,?35,FBUSER,!,?1,FBR,!
Q
Q K DFN,A,FBIDC,FBDT,FBOUT,FBUSER,FBNM,FBSSN,X,Y,UL,FBR,DIC,C,DIYS,I,J,Z Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAACH 1591 printed Apr 09, 2024@21:05:19 Page 2
FBAACH ;AISC/GRR-DISPLAY ID CARD HISTORY FOR PATIENT ;13APR86
+1 ;;3.5;FEE BASIS;;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 SET IOP=$SELECT($DATA(ION):ION,1:"HOME")
DO ^%ZIS
KILL IOP
SET UL=""
FOR A=1:1:79
SET UL=UL_"="
RD KILL FBOUT
WRITE !!
SET DIC="^FBAAA("
SET DIC(0)="AEQM"
DO ^DIC
if X="^"!(X="")
GOTO Q
if Y<0
GOTO RD
SET DFN=+Y
+1 IF '$DATA(^FBAAA(DFN,4))
IF '$DATA(^FBAA(161.83,DFN))
WRITE !!,"Patient has never been assigned ID Card!"
GOTO RD
+2 SET FBNM=$SELECT($DATA(^DPT(DFN,0)):$PIECE(^(0),"^"),1:"")
SET FBSSN=$$SSN^FBAAUTL(DFN)
+3 IF '$DATA(^FBAAA(DFN,4))
IF $DATA(^FBAA(161.83,DFN))
DO HED
DO NOC
DO HED2
DO LISTH
GOTO RD
+4 SET Y(0)=^FBAAA(DFN,4)
SET FBIDC=$PIECE(Y(0),"^",1)
SET FBDT=$PIECE(Y(0),"^",2)
+5 DO HED
WRITE !,?6,"Current ID Card: ",FBIDC,?32,"Date Issued: ",$EXTRACT(FBDT,4,5),"/",$EXTRACT(FBDT,6,7),"/",$EXTRACT(FBDT,2,3)
+6 IF $DATA(^FBAA(161.83,DFN))
DO HED2
DO LISTH
GOTO RD
+7 WRITE !!,?5,"No previous ID Cards!",!
GOTO RD
HED WRITE @IOF,"Patient: ",FBNM,?41,"SSN: ",FBSSN,!
QUIT
NOC WRITE !,"Does not currently have ID Card!",!
QUIT
HED2 WRITE !!,"Date/Time Changed",?22,"Old Card #",?35,"Person Who Changed",!,?5,"Reason For Change",!,UL
QUIT
LISTH IF $DATA(^FBAA(161.83,DFN,1))
FOR J=0:0
SET J=$ORDER(^FBAA(161.83,DFN,1,J))
if J'>0
QUIT
IF $DATA(^(J,0))
SET Y(0)=^(0)
DO GOT
if $GET(FBOUT)
QUIT
+1 QUIT
GOT SET FBDT=$PIECE(Y(0),"^")
SET FBIDC=$PIECE(Y(0),"^",2)
SET FBR=$PIECE(Y(0),"^",3)
SET FBUSER=$PIECE(Y(0),"^",4)
+1 SET X=FBDT
DO TM^FBAAUTL
SET Y=FBDT
DO PDF^FBAAUTL
SET FBUSER=$SELECT(FBUSER="":"UNKNOWN",$DATA(^VA(200,FBUSER,0)):$PIECE(^(0),"^",1),1:"UNKNOWN")
+2 IF $Y+2>IOSL
SET DIR(0)="E"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
SET FBOUT=1
if $GET(FBOUT)
QUIT
DO HED
DO HED2
+3 WRITE !,Y,?10,$JUSTIFY(X,8),?23,FBIDC,?35,FBUSER,!,?1,FBR,!
+4 QUIT
Q KILL DFN,A,FBIDC,FBDT,FBOUT,FBUSER,FBNM,FBSSN,X,Y,UL,FBR,DIC,C,DIYS,I,J,Z
QUIT
