FBCHSTA.m

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 ---FBCHSTA   1388     printed  Apr 09, 2024@21:06:38                                                                                                                                                                                                     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