| [613] | 1 | FBAACH ;AISC/GRR-DISPLAY ID CARD HISTORY FOR PATIENT ;13APR86
|
|---|
| 2 | ;;3.5;FEE BASIS;;JAN 30, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP S UL="" F A=1:1:79 S UL=UL_"="
|
|---|
| 5 | RD K FBOUT W !! S DIC="^FBAAA(",DIC(0)="AEQM" D ^DIC G Q:X="^"!(X=""),RD:Y<0 S DFN=+Y
|
|---|
| 6 | I '$D(^FBAAA(DFN,4)),'$D(^FBAA(161.83,DFN)) W !!,"Patient has never been assigned ID Card!" G RD
|
|---|
| 7 | S FBNM=$S($D(^DPT(DFN,0)):$P(^(0),"^"),1:""),FBSSN=$$SSN^FBAAUTL(DFN)
|
|---|
| 8 | I '$D(^FBAAA(DFN,4)),$D(^FBAA(161.83,DFN)) D HED,NOC,HED2,LISTH G RD
|
|---|
| 9 | S Y(0)=^FBAAA(DFN,4),FBIDC=$P(Y(0),"^",1),FBDT=$P(Y(0),"^",2)
|
|---|
| 10 | D HED W !,?6,"Current ID Card: ",FBIDC,?32,"Date Issued: ",$E(FBDT,4,5),"/",$E(FBDT,6,7),"/",$E(FBDT,2,3)
|
|---|
| 11 | I $D(^FBAA(161.83,DFN)) D HED2,LISTH G RD
|
|---|
| 12 | W !!,?5,"No previous ID Cards!",! G RD
|
|---|
| 13 | HED W @IOF,"Patient: ",FBNM,?41,"SSN: ",FBSSN,! Q
|
|---|
| 14 | NOC W !,"Does not currently have ID Card!",! Q
|
|---|
| 15 | HED2 W !!,"Date/Time Changed",?22,"Old Card #",?35,"Person Who Changed",!,?5,"Reason For Change",!,UL Q
|
|---|
| 16 | 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)
|
|---|
| 17 | Q
|
|---|
| 18 | GOT S FBDT=$P(Y(0),"^"),FBIDC=$P(Y(0),"^",2),FBR=$P(Y(0),"^",3),FBUSER=$P(Y(0),"^",4)
|
|---|
| 19 | 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")
|
|---|
| 20 | I $Y+2>IOSL S DIR(0)="E" D ^DIR K DIR S:$D(DIRUT) FBOUT=1 Q:$G(FBOUT) D HED,HED2
|
|---|
| 21 | W !,Y,?10,$J(X,8),?23,FBIDC,?35,FBUSER,!,?1,FBR,!
|
|---|
| 22 | Q
|
|---|
| 23 | Q K DFN,A,FBIDC,FBDT,FBOUT,FBUSER,FBNM,FBSSN,X,Y,UL,FBR,DIC,C,DIYS,I,J,Z Q
|
|---|
