- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAPOC 1070 printed Feb 18, 2025@23:22:38 Page 2
- FBAAPOC ;AISC/GRR-PRINT OBSOLETE CARDS ;15APR86
- +1 ;;3.5;FEE BASIS;;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 SET VAR=""
- SET PGM="START^FBAAPOC"
- DO ZIS^FBAAUTL
- if FBPOP
- GOTO Q
- START SET FBOUT=0
- USE IO
- SET UL=""
- FOR A=1:1:80
- SET UL=UL_"="
- +1 if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- DO HED
- +2 SET J=0
- FOR JJ=0:0
- SET J=$ORDER(^FBAA(161.83,"C",J))
- if J'>0!($GET(FBOUT))
- QUIT
- FOR K=0:0
- SET K=$ORDER(^FBAA(161.83,"C",J,K))
- if K'>0!($GET(FBOUT))
- QUIT
- FOR L=0:0
- SET L=$ORDER(^FBAA(161.83,"C",J,K,L))
- if L'>0!($GET(FBOUT))
- QUIT
- IF $DATA(^FBAA(161.83,K,1,L,0))
- SET Y(0)=^(0)
- DO GOT
- if FBOUT
- QUIT
- Q WRITE !
- KILL A,J,K,JJ,UL,FBOUT,FBDT,FBNM,FBSSN,FBR,FBPOP,L,Y
- +1 DO CLOSE^FBAAUTL
- QUIT
- GOT SET FBDT=$PIECE(Y(0),"^")
- SET FBNM=$SELECT($DATA(^DPT(K,0)):$PIECE(^(0),"^"),1:"")
- SET FBSSN=$SELECT(FBNM="":"",1:$$SSN^FBAAUTL(K))
- SET FBDT=$SELECT(FBDT[".":$PIECE(FBDT,"."),1:FBDT)
- SET FBR=$PIECE(Y(0),"^",3)
- +1 IF $EXTRACT(IOST,1,2)["C-"
- IF $Y+4>IOSL
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if 'Y
- SET FBOUT=1
- if FBOUT
- QUIT
- WRITE @IOF
- DO HED
- +2 IF '$TEST
- IF $Y+4>IOSL
- WRITE @IOF
- +3 WRITE !!,J,?10,FBNM,?42,$GET(FBSSN),?61,$$DATX^FBAAUTL(FBDT),!,?2,FBR
- +4 QUIT
- HED WRITE !,"Old Card ",?10,"Patient Name",?42,"Pt.ID",?61,"Change Date",!?1,"Number",!?2,"Reason For Change",!,UL
- QUIT
