- FBCHSTA ;AISC/DMK - DISPLAYS PENDING INPATIENT DISPOSITIONS ;7/11/14 17:31
- ;;3.5;FEE BASIS;**154**;JAN 30, 1995;Build 12
- ;;Per VA Directive 6402, this routine should not be modified.
- D HOME^%ZIS,^FBAASTA S DIR(0)="E" D ^DIR K DIR Q:'Y W @IOF
- EN D DT^DICRW S FBDT=DT,FBSW=1,CNT=0
- S Q="-",$P(Q,"-",80)="-" D HED
- F I=FBDT:0 S I=$O(^FB7078("AD",6,I)) Q:I'>0 F J=0:0 S J=$O(^FB7078("AD",6,I,J)) Q:J'>0 D TRANS
- STAT1 I $D(^FB7078("AC","I")) F I=0:0 S I=$O(^FB7078("AC","I",I)) Q:I'>0 F J=0:0 S J=$O(^FB7078("AC","I",I,J)) Q:J'>0 D TRANS
- END W:CNT'>0 !,$S($D(^XUSEC("FBAA LEVEL 2",DUZ)):"There are ",1:"You have "),"no inpatients pending disposition." K CNT,FBAD,FBDT,FBDUZ,FBTYPE,FBVEN,FBVET,I,J,POP,Q,Y,FBFLG Q
- TRANS S Y(0)=^FB7078(J,0) Q:$P(Y(0),"^",9)="DC"
- S FBVET=$P(Y(0),"^",3),FBVEN=$P(Y(0),"^",2),FBVEN=$P(FBVEN,";"),FBAD=$P(Y(0),"^",4),FBDUZ=$P(Y(0),"^",8),FBTYPE=$P(Y(0),"^",11)
- Q:FBTYPE'=6
- Q:DUZ'=FBDUZ&('$D(^XUSEC("FBAA LEVEL 2",DUZ)))
- S FBVET=$P(^DPT(FBVET,0),"^",1),FBVEN=$S($D(^FBAAV(FBVEN)):$P(^FBAAV(FBVEN,0),"^",1),1:"UNKNOWN")
- S X1=FBDT,X2=FBAD D D^%DTC
- S FBFLG=$S(X>10:"++",1:""),Y=FBAD D PDF^FBAAUTL S FBAD=Y
- W !,FBFLG,?5,FBVET,?35,FBVEN,?65,FBAD
- S CNT=CNT+1 Q
- HED ;S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP W @IOF
- W !,?29,"PENDING 7078's",!,?21,"('++' indicates LOS > 10 days)",!,"Veteran",?35,"Vendor",?65,"Admission Date",!,Q Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHSTA 1388 printed Jan 18, 2025@02:59:14 Page 2
- FBCHSTA ;AISC/DMK - DISPLAYS PENDING INPATIENT DISPOSITIONS ;7/11/14 17:31
- +1 ;;3.5;FEE BASIS;**154**;JAN 30, 1995;Build 12
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 DO HOME^%ZIS
- DO ^FBAASTA
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if 'Y
- QUIT
- WRITE @IOF
- EN DO DT^DICRW
- SET FBDT=DT
- SET FBSW=1
- SET CNT=0
- +1 SET Q="-"
- SET $PIECE(Q,"-",80)="-"
- DO HED
- +2 FOR I=FBDT:0
- SET I=$ORDER(^FB7078("AD",6,I))
- if I'>0
- QUIT
- FOR J=0:0
- SET J=$ORDER(^FB7078("AD",6,I,J))
- if J'>0
- QUIT
- DO TRANS
- STAT1 IF $DATA(^FB7078("AC","I"))
- FOR I=0:0
- SET I=$ORDER(^FB7078("AC","I",I))
- if I'>0
- QUIT
- FOR J=0:0
- SET J=$ORDER(^FB7078("AC","I",I,J))
- if J'>0
- QUIT
- DO TRANS
- END if CNT'>0
- WRITE !,$SELECT($DATA(^XUSEC("FBAA LEVEL 2",DUZ)):"There are ",1:"You have "),"no inpatients pending disposition."
- KILL CNT,FBAD,FBDT,FBDUZ,FBTYPE,FBVEN,FBVET,I,J,POP,Q,Y,FBFLG
- QUIT
- TRANS SET Y(0)=^FB7078(J,0)
- if $PIECE(Y(0),"^",9)="DC"
- QUIT
- +1 SET FBVET=$PIECE(Y(0),"^",3)
- SET FBVEN=$PIECE(Y(0),"^",2)
- SET FBVEN=$PIECE(FBVEN,";")
- SET FBAD=$PIECE(Y(0),"^",4)
- SET FBDUZ=$PIECE(Y(0),"^",8)
- SET FBTYPE=$PIECE(Y(0),"^",11)
- +2 if FBTYPE'=6
- QUIT
- +3 if DUZ'=FBDUZ&('$DATA(^XUSEC("FBAA LEVEL 2",DUZ)))
- QUIT
- +4 SET FBVET=$PIECE(^DPT(FBVET,0),"^",1)
- SET FBVEN=$SELECT($DATA(^FBAAV(FBVEN)):$PIECE(^FBAAV(FBVEN,0),"^",1),1:"UNKNOWN")
- +5 SET X1=FBDT
- SET X2=FBAD
- DO D^%DTC
- +6 SET FBFLG=$SELECT(X>10:"++",1:"")
- SET Y=FBAD
- DO PDF^FBAAUTL
- SET FBAD=Y
- +7 WRITE !,FBFLG,?5,FBVET,?35,FBVEN,?65,FBAD
- +8 SET CNT=CNT+1
- QUIT
- HED ;S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP W @IOF
- +1 WRITE !,?29,"PENDING 7078's",!,?21,"('++' indicates LOS > 10 days)",!,"Veteran",?35,"Vendor",?65,"Admission Date",!,Q
- QUIT