- 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
- Q
- ;
- 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
- Q
- ;
- 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)
