Routine: ADGIP0

ADGIP0 ; IHS/ADC/PDW/ENM - INPATIENT LIST ; [ 03/25/1999  11:48 AM ]

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

A ; -- driver

 D DEV I POP D Q Q

 I $D(IO("Q")) D QUE,Q Q

 D LPWD,^ADGIP1,Q Q

DEV ;--device selection

 W !!,"Paper margin must be at least 110" S %ZIS="PQ" D ^%ZIS Q

QUE ;--queued output

 K IO("Q")  S ZTRTN="LPWD^ADGIP0",ZTDESC="INPATIENT LIST"

 D ^%ZTLOAD,^%ZISC K ZTSK  Q

Q ; -- cleanup

 K DIR,DA,DR,DGDT,Y,X,ZTSK

 D HOME^%ZIS  Q

LPWD ;--loop ward

 N WARD,DFN

 K ^TMP("DGZINP",$J)

 S WARD="",DGCNT=0 F  S WARD=$O(^DPT("CN",WARD)) Q:WARD=""  D

 . S DFN=0 F  S DFN=$O(^DPT("CN",WARD,DFN)) Q:'DFN  D 1

1 ;

 N IFN,NAME,TS,COM,UTL

 S IFN=^DPT("CN",WARD,DFN),DGDT=$P($P(^DGPM(IFN,0),U),".",1)

 S NAME=$P($G(^DPT(DFN,0)),U),TS=$G(^(.103))

 S COM=$P($G(^AUPNPAT(DFN,11)),U,18)

 ;--utility node

 S UTL=DGDT_U_$$AGE_U_WARD_U_TS_U_COM_U_$$HRCN^ADGF_U_$$MCR_U_$$MCD

 S ^TMP("DGZINP",$J,NAME,DFN)=UTL,DGCNT=DGCNT+1

MCR() ; -- medicare number & suffix

 N X S X=$G(^AUPNMCR(DFN,0)) Q $P(X,U,3)_$G(^AUTTMCS(+$P(X,U,4),0))

MCD() ; -- medicaid #

 Q $P($G(^AUPNMCD(+$O(^AUPNMCD("B",DFN,0)),0)),U,3)

AGE() ; -- age

 K ^UTILITY("DIQ1",$J) S DA=DFN,DR=1102.98,DIC=9000001 D EN^DIQ1

 S X=$G(^UTILITY("DIQ1",$J,9000001,DFN,1102.98)) K ^UTILITY("DIQ1",$J)

 Q $S($L(X)=5:" "_X,1:X)

ADGIP0    ; IHS/ADC/PDW/ENM - INPATIENT LIST ; [ 03/25/1999  11:48 AM ]

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

 +2       ;

A         ; -- driver

 +1        DO DEV

           IF POP

               DO Q

               QUIT

 +2        IF $DATA(IO("Q"))

               DO QUE

               DO Q

               QUIT

 +3        DO LPWD

           DO ^ADGIP1

           DO Q

           QUIT

 +4       ;

DEV       ;--device selection

 +1        WRITE !!,"Paper margin must be at least 110"

           SET %ZIS="PQ"

           DO ^%ZIS

           QUIT

 +2       ;

QUE       ;--queued output

 +1        KILL IO("Q")

           SET ZTRTN="LPWD^ADGIP0"

           SET ZTDESC="INPATIENT LIST"

 +2        DO ^%ZTLOAD

           DO ^%ZISC

           KILL ZTSK

           QUIT

 +3       ;

Q         ; -- cleanup

 +1        KILL DIR,DA,DR,DGDT,Y,X,ZTSK

 +2        DO HOME^%ZIS

           QUIT

 +3       ;

LPWD      ;--loop ward

 +1        NEW WARD,DFN

 +2        KILL ^TMP("DGZINP",$JOB)

 +3        SET WARD=""

           SET DGCNT=0

FOR

               SET WARD=$ORDER(^DPT("CN",WARD))

               IF WARD=""

                   QUIT

               Begin DoDot:1

 +4                SET DFN=0

FOR

                       SET DFN=$ORDER(^DPT("CN",WARD,DFN))

                       IF 'DFN

                           QUIT

                       DO 1

               End DoDot:1

 +5        QUIT

 +6       ;

1         ;

 +1        NEW IFN,NAME,TS,COM,UTL

 +2        SET IFN=^DPT("CN",WARD,DFN)

           SET DGDT=$PIECE($PIECE(^DGPM(IFN,0),U),".",1)

 +3        SET NAME=$PIECE($GET(^DPT(DFN,0)),U)

           SET TS=$GET(^(.103))

 +4        SET COM=$PIECE($GET(^AUPNPAT(DFN,11)),U,18)

 +5       ;--utility node

 +6        SET UTL=DGDT_U_$$AGE_U_WARD_U_TS_U_COM_U_$$HRCN^ADGF_U_$$MCR_U_$$MCD

 +7        SET ^TMP("DGZINP",$JOB,NAME,DFN)=UTL

           SET DGCNT=DGCNT+1

 +8        QUIT

 +9       ;

MCR()     ; -- medicare number & suffix

 +1        NEW X

           SET X=$GET(^AUPNMCR(DFN,0))

           QUIT $PIECE(X,U,3)_$GET(^AUTTMCS(+$PIECE(X,U,4),0))

 +2       ;

MCD()     ; -- medicaid #

 +1        QUIT $PIECE($GET(^AUPNMCD(+$ORDER(^AUPNMCD("B",DFN,0)),0)),U,3)

 +2       ;

AGE()     ; -- age

 +1        KILL ^UTILITY("DIQ1",$JOB)

           SET DA=DFN

           SET DR=1102.98

           SET DIC=9000001

           DO EN^DIQ1

 +2        SET X=$GET(^UTILITY("DIQ1",$JOB,9000001,DFN,1102.98))

           KILL ^UTILITY("DIQ1",$JOB)

 +3        QUIT $SELECT($LENGTH(X)=5:" "_X,1:X)

ADGIP0.m