Routine: ADGSVP

ADGSVP ; IHS/ADC/PDW/ENM - HSA-202 PRINT ; [ 03/25/1999  11:48 AM ]

 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 S DGLINE="",$P(DGLINE,"-",80)=""

A ; -- driver

 D HD,P1,LS,P2 Q

HD N X,Y S X="RANGE OF MONTHS REPORT OF INPATIENT SERVICES IHS HOSPITALS"

 W @IOF W ?80-$L(X)/2,X,!,DGLINE,!,"Name and Location of Hospital"

 W ?64,"Month and Year",!!?5,$P($G(^DIC(4,+DUZ(2),0)),U)

 S X=$G(^AUTTLOC(+DUZ(2),0))

 W "    ",$P(X,U,13)_", "_$P($G(^DIC(5,+$P(+X,U,14),0)),U)

 S Y=$E(DGSMON,1,3)+1700,X=$E(DGSMON,4,5)

 W ?50,$P($P($T(MON),";;",2)," ",X)_" "_Y

 S Y=$E(DGEMON,1,3)+1700,X=$E(DGEMON,4,5)

 W " to ",$P($P($T(MON),";;",2)," ",X)_" "_Y,!,DGLINE Q

P1 S X="Part I - Service and Census" W !?80-$L(X)/2,X,!,DGLINE

 W !?31,"Bom",?48,"Discharges",?64,"Eom",?70,"Inpatient"

 W !?1,"Medical Services Provided",?30,"Census",?40,"Adm"

 W ?48,"Death",?55,"Other",?63,"Census",?72,"Days",!,DGLINE,! Q

LS N S,I,J F S=1,2,3,5,6,7 D WS

 D TOT Q

WS ;I S=1 W:DGA(3,8) ?40,DGA(3,8)_"t" W:DGA(3,7) ?55,DGA(3,7)_"t"

 ;I S=2 W:DGA(4,8) ?40,DGA(4,8)_"t" W:DGA(4,7) ?54,DGA(4,7)_"t"

 ;I S=3 W:DGA(3,7) ?40,DGA(3,7)_"t" W:DGA(3,8) ?54,DGA(3,8)_"t"

 W !,$P($T(SRV+S),";;",2)

 W ?32,$J(DGA(S,1),3),?40,$J(DGA(S,2),3),?48,$J(DGA(S,3),3)

 W ?55,$J(DGA(S,4),3),?64,$J(DGA(S,5),3),?72,$J(DGA(S,6),4),! Q

TOT ; -- totals

 W ?30,"-----",?38,"-----",?46,"-----",?53,"-----",?62,"-----"

 W ?70,"------" F I=1:1:6 S DGX(I)=0

 F I=1,2,3,5,6,7 F J=1:1:6 S DGX(J)=DGX(J)+DGA(I,J)  ;totals

 W !?10,"TOTAL",?32,$J(DGX(1),3),?40,$J(DGX(2),3),?48,$J(DGX(3),3)

 W ?55,$J(DGX(4),3),?64,$J(DGX(5),3),?72,$J(DGX(6),4),!,DGLINE

 ; -- newborn

 ;W ! W:DGA(4,7) ?40,DGA(4,7)_"t" W:DGA(4,8) ?54,DGA(4,8)_"t"

 W !,"NEWBORN"

 W ?32,$J(DGA(4,1),3),?40,$J(DGA(4,2),3),?48,$J(DGA(4,3),3)

 W ?55,$J(DGA(4,4),3),?64,$J(DGA(4,5),3),?72,$J(DGA(4,6),4),!,DGLINE

P2 W !?26,"Part II - Special Information",!,DGLINE

 W !!,"Peak Census, Excluding Newborn................................."

 W ?64,DGMAX

 W !!,"Minimum Census, Excluding Newborn..............................."

 W ?64,DGMIN Q

MON ;;JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC

SRV ;;

 ;;MEDICAL & SURGICAL (Adult)

 ;;MEDICAL & SURGICAL (Ped.)

 ;;OBSTETRIC

 ;;NEWBORN

 ;;TUBERCULOSIS

 ;;ALCOHOLISM/SUBSTANCE ABUSE

 ;;MENTAL HEALTH

ADGSVP    ; IHS/ADC/PDW/ENM - HSA-202 PRINT ; [ 03/25/1999  11:48 AM ]

 +1       ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 +2       ;

 +3        SET DGLINE=""

           SET $PIECE(DGLINE,"-",80)=""

A         ; -- driver

 +1        DO HD

           DO P1

           DO LS

           DO P2

           QUIT

 +2       ;

HD         NEW X,Y

           SET X="RANGE OF MONTHS REPORT OF INPATIENT SERVICES IHS HOSPITALS"

 +1        WRITE @IOF

           WRITE ?80-$LENGTH(X)/2,X,!,DGLINE,!,"Name and Location of Hospital"

 +2        WRITE ?64,"Month and Year",!!?5,$PIECE($GET(^DIC(4,+DUZ(2),0)),U)

 +3        SET X=$GET(^AUTTLOC(+DUZ(2),0))

 +4        WRITE "    ",$PIECE(X,U,13)_", "_$PIECE($GET(^DIC(5,+$PIECE(+X,U,14),0)),U)

 +5        SET Y=$EXTRACT(DGSMON,1,3)+1700

           SET X=$EXTRACT(DGSMON,4,5)

 +6        WRITE ?50,$PIECE($PIECE($TEXT(MON),";;",2)," ",X)_" "_Y

 +7        SET Y=$EXTRACT(DGEMON,1,3)+1700

           SET X=$EXTRACT(DGEMON,4,5)

 +8        WRITE " to ",$PIECE($PIECE($TEXT(MON),";;",2)," ",X)_" "_Y,!,DGLINE

           QUIT

 +9       ;

P1         SET X="Part I - Service and Census"

           WRITE !?80-$LENGTH(X)/2,X,!,DGLINE

 +1        WRITE !?31,"Bom",?48,"Discharges",?64,"Eom",?70,"Inpatient"

 +2        WRITE !?1,"Medical Services Provided",?30,"Census",?40,"Adm"

 +3        WRITE ?48,"Death",?55,"Other",?63,"Census",?72,"Days",!,DGLINE,!

           QUIT

 +4       ;

LS         NEW S,I,J

           FOR S=1,2,3,5,6,7

               DO WS

 +1        DO TOT

           QUIT

 +2       ;

WS        ;I S=1 W:DGA(3,8) ?40,DGA(3,8)_"t" W:DGA(3,7) ?55,DGA(3,7)_"t"

 +1       ;I S=2 W:DGA(4,8) ?40,DGA(4,8)_"t" W:DGA(4,7) ?54,DGA(4,7)_"t"

 +2       ;I S=3 W:DGA(3,7) ?40,DGA(3,7)_"t" W:DGA(3,8) ?54,DGA(3,8)_"t"

 +3        WRITE !,$PIECE($TEXT(SRV+S),";;",2)

 +4        WRITE ?32,$JUSTIFY(DGA(S,1),3),?40,$JUSTIFY(DGA(S,2),3),?48,$JUSTIFY(DGA(S,3),3)

 +5        WRITE ?55,$JUSTIFY(DGA(S,4),3),?64,$JUSTIFY(DGA(S,5),3),?72,$JUSTIFY(DGA(S,6),4),!

           QUIT

 +6       ;

TOT       ; -- totals

 +1        WRITE ?30,"-----",?38,"-----",?46,"-----",?53,"-----",?62,"-----"

 +2        WRITE ?70,"------"

           FOR I=1:1:6

               SET DGX(I)=0

 +3       ;totals

           FOR I=1,2,3,5,6,7

               FOR J=1:1:6

                   SET DGX(J)=DGX(J)+DGA(I,J)

 +4        WRITE !?10,"TOTAL",?32,$JUSTIFY(DGX(1),3),?40,$JUSTIFY(DGX(2),3),?48,$JUSTIFY(DGX(3),3)

 +5        WRITE ?55,$JUSTIFY(DGX(4),3),?64,$JUSTIFY(DGX(5),3),?72,$JUSTIFY(DGX(6),4),!,DGLINE

 +6       ; -- newborn

 +7       ;W ! W:DGA(4,7) ?40,DGA(4,7)_"t" W:DGA(4,8) ?54,DGA(4,8)_"t"

 +8        WRITE !,"NEWBORN"

 +9        WRITE ?32,$JUSTIFY(DGA(4,1),3),?40,$JUSTIFY(DGA(4,2),3),?48,$JUSTIFY(DGA(4,3),3)

 +10       WRITE ?55,$JUSTIFY(DGA(4,4),3),?64,$JUSTIFY(DGA(4,5),3),?72,$JUSTIFY(DGA(4,6),4),!,DGLINE

 +11       QUIT

 +12      ;

P2         WRITE !?26,"Part II - Special Information",!,DGLINE

 +1        WRITE !!,"Peak Census, Excluding Newborn................................."

 +2        WRITE ?64,DGMAX

 +3        WRITE !!,"Minimum Census, Excluding Newborn..............................."

 +4        WRITE ?64,DGMIN

           QUIT

 +5       ;

MON       ;;JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC

SRV       ;;

 +1       ;;MEDICAL & SURGICAL (Adult)

 +2       ;;MEDICAL & SURGICAL (Ped.)

 +3       ;;OBSTETRIC

 +4       ;;NEWBORN

 +5       ;;TUBERCULOSIS

 +6       ;;ALCOHOLISM/SUBSTANCE ABUSE

 +7       ;;MENTAL HEALTH

ADGSVP.m