16 lines
1.0 KiB
Mathematica
16 lines
1.0 KiB
Mathematica
FBAAPOC ;AISC/GRR-PRINT OBSOLETE CARDS ;15APR86
|
|
;;3.5;FEE BASIS;;JAN 30, 1995
|
|
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
S VAR="",PGM="START^FBAAPOC" D ZIS^FBAAUTL G:FBPOP Q
|
|
START S FBOUT=0 U IO S UL="" F A=1:1:80 S UL=UL_"="
|
|
W:$E(IOST,1,2)="C-" @IOF D HED
|
|
S J=0 F JJ=0:0 S J=$O(^FBAA(161.83,"C",J)) Q:J'>0!($G(FBOUT)) F K=0:0 S K=$O(^FBAA(161.83,"C",J,K)) Q:K'>0!($G(FBOUT)) F L=0:0 S L=$O(^FBAA(161.83,"C",J,K,L)) Q:L'>0!($G(FBOUT)) I $D(^FBAA(161.83,K,1,L,0)) S Y(0)=^(0) D GOT Q:FBOUT
|
|
Q W ! K A,J,K,JJ,UL,FBOUT,FBDT,FBNM,FBSSN,FBR,FBPOP,L,Y
|
|
D CLOSE^FBAAUTL Q
|
|
GOT S FBDT=$P(Y(0),"^"),FBNM=$S($D(^DPT(K,0)):$P(^(0),"^"),1:""),FBSSN=$S(FBNM="":"",1:$$SSN^FBAAUTL(K)),FBDT=$S(FBDT[".":$P(FBDT,"."),1:FBDT),FBR=$P(Y(0),"^",3)
|
|
I $E(IOST,1,2)["C-",$Y+4>IOSL S DIR(0)="E" D ^DIR K DIR S:'Y FBOUT=1 Q:FBOUT W @IOF D HED
|
|
E I $Y+4>IOSL W @IOF
|
|
W !!,J,?10,FBNM,?42,$G(FBSSN),?61,$$DATX^FBAAUTL(FBDT),!,?2,FBR
|
|
Q
|
|
HED W !,"Old Card ",?10,"Patient Name",?42,"Pt.ID",?61,"Change Date",!?1,"Number",!?2,"Reason For Change",!,UL Q
|