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 Dec 13, 2024@01:58:01 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
