ADGWMM2 ; IHS/ADC/PDW/ENM - WARD MEDICARE/MEDICAID PRINT ; [ 10/29/1999 1:31 PM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;**3**;MAR 25, 1999
;
LDT ;EP; -- loop by disch date
K ^TMP("ADGWMM",$J)
NEW DGD,END,DGN
S DGD=DGBD-.0001,END=DGED+.2400
F S DGD=$O(^DGPM("ATT3",DGD)) Q:'DGD!(DGD>END) D
. S DGN=0 F S DGN=$O(^DGPM("ATT3",DGD,DGN)) Q:'DGN D
.. S DFN=$P(^DGPM(DGN,0),U,3),DGPMCA=$P(^(0),U,14)
.. D CHECK I DGMR="",DGMD="",DGPI="" Q
.. S W=$$DWD
.. S W=$$VAL^XBDIQ1(42,W,.01) I (DGW'=0),(W'=DGW) Q
.. S ^TMP("ADGWMM",$J,W,DGD,DGN)=DFN_U_DGPMCA_U_DGMR_U_DGMD_U_DGPI_U_DGPINM
;
D HDH,TMPLP Q
;
TMPLP ; -- loop thru tmp file
NEW X
;IHS/DSD/ENM NEXT LINE COPIED/MODIFIED
;S W=0 F S W=$O(^TMP("ADGWMM",$J,W)) Q:'W!(DGSTOP=U) D
S W=0 F S W=$O(^TMP("ADGWMM",$J,W)) Q:W']""!(DGSTOP=U) D
. S DGD=0 F S DGD=$O(^TMP("ADGWMM",$J,W,DGD)) Q:'DGD!(DGSTOP=U) D
.. S DGN=0
.. F S DGN=$O(^TMP("ADGWMM",$J,W,DGD,DGN)) Q:'DGN!(DGSTOP=U) D
... S DGS=^TMP("ADGWMM",$J,W,DGD,DGN),DFN=+DGS
... D PRINT
Q
;
CHECK ; -- check for insurance types requested
S (DGMD,DGMR,DGPI,DGPINM)=""
I $D(^AUPNMCR("B",DFN)) S IFN=$O(^(DFN,0)) D MCR
I $D(^AUPNMCD("B",DFN)) S IFN=$O(^(DFN,0)) D MCD
I $D(^AUPNPRVT("B",DFN)) S IFN=$O(^(DFN,0)) D INS
Q
;
MCR ; -- medicare
NEW ED,EED
F ED=0:0 S ED=$O(^AUPNMCR(IFN,"11",ED)) Q:'ED D
. S EED=$P(^AUPNMCR(IFN,11,ED,0),U,2),DGMR="" I EED>DT!('+EED) D
.. S DGMR=$P(^AUPNMCR(IFN,0),U,3)_$P(^AUTTMCS($P(^(0),U,4),0),U)
Q
;
MCD ; -- medicaid
NEW ED,EED
F ED=0:0 S ED=$O(^AUPNMCD(IFN,"11",ED)) Q:'ED D
. S EED=$P(^AUPNMCD(IFN,11,ED,0),U,2),DGMD=""
. I EED>DT!('+EED) S DGMD=$P(^AUPNMCD(IFN,0),U,3)
Q
;
INS ; -- private insurance
NEW ED,EED
F ED=0:0 S ED=$O(^AUPNPRVT(IFN,"11",ED)) Q:'ED D
. S EED=$P(^AUPNPRVT(IFN,11,ED,0),U,7),DGPI="" I EED>DT!('+EED) D
.. S DGPI=$P(^AUPNPRVT(IFN,"11",ED,0),U,2)
.. S DGPINM=$P(^AUTNINS($P(^AUPNPRVT(IFN,"11",ED,0),U,1),0),U,1)
Q
;
PRINT ; -- print
NEW MR,MD,PV,PVN
I $Y>(IOSL-6) D NEWPG Q:DGSTOP=U
W !,$E($P(^DPT(DFN,0),U),1,20) ;name
I $D(DUZ(2))&($D(^AUPNPAT(DFN,41,DUZ(2),0))) W ?22,$J($P(^(0),U,2),6)
S DGPMCA=$P(DGS,U,2) ;corr admit
S Y=+^DGPM(DGPMCA,0) X ^DD("DD") W ?32,Y ;admission date/time
S Y=DGD X ^DD("DD") W ?50,Y ;dsch date/time
W ?72,$E(W,1,5)
W !?2,"Admit Dx: ",$P(^DGPM(DGPMCA,0),U,10) ;admitting Dx
S MR=$P(DGS,U,3),MD=$P(DGS,U,4),PV=$P(DGS,U,5),PVN=$P(DGS,U,6)
I MD W ?40,"MCAID #: ",MD
I MR W ?61,"MCARE #: ",MR
I PV W !?2,"Insurer: ",PVN," #",PV
W ! Q
;
HDH ; -- heading
I DGPG>0!(IOST["C-") W @IOF
D CONF^ADGUTIL(12)
W !?24,"MEDICARE/MEDICAID/INSURANCE LIST"
S DGPG=DGPG+1
S Y=DT X ^DD("DD") W ?69,Y
W !?17,"for Discharge Dates: ",$$RANGE
W !?2,"Patient Name",?23,"HRCN",?32,"Admit Date",?50,"Dsch Date"
W ?72,"Ward"
S LN="",$P(LN,"-",IOM)="" W !,LN Q
;
NEWPG ; -- end of page control
I IOST["C-" K DIR S DIR(0)="E" D ^DIR S DGSTOP=X Q:X=U
D HDH Q
;
RANGE() ; -- printable date range
NEW X,Y,R
S Y=DGBD X ^DD("DD") S R=Y_" to "
S Y=DGED X ^DD("DD") S R=R_Y
Q R
;
DWD() ; -- find disch ward
N X,Y,Z S Y=$G(^DGPM(+$P(^DGPM(DGPMCA,0),U,17),0)),Y=$$IDATE(+Y)
S X=$O(^DGPM("ATID2",DFN,Y))
I X>$$IDATE(+^DGPM(DGPMCA,0)) S Z=DGPMCA
I X]"",'$D(Z) S Z=$O(^DGPM("ATID2",DFN,X,0))
I X="" S Z=DGPMCA
Q $P($G(^DGPM(+Z,0)),U,6)
;
IDATE(X) ; -- inverse date
Q (9999999.9999999-X)
ADGWMM2 ; IHS/ADC/PDW/ENM - WARD MEDICARE/MEDICAID PRINT ; [ 10/29/1999 1:31 PM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**3**;MAR 25, 1999
+2 ;
LDT ;EP; -- loop by disch date
+1 KILL ^TMP("ADGWMM",$JOB)
+2 NEW DGD,END,DGN
+3 SET DGD=DGBD-.0001
SET END=DGED+.2400
+4 FOR
SET DGD=$ORDER(^DGPM("ATT3",DGD))
IF 'DGD!(DGD>END)
QUIT
Begin DoDot:1
+5 SET DGN=0
FOR
SET DGN=$ORDER(^DGPM("ATT3",DGD,DGN))
IF 'DGN
QUIT
Begin DoDot:2
+6 SET DFN=$PIECE(^DGPM(DGN,0),U,3)
SET DGPMCA=$PIECE(^(0),U,14)
+7 DO CHECK
IF DGMR=""
IF DGMD=""
IF DGPI=""
QUIT
+8 SET W=$$DWD
+9 SET W=$$VAL^XBDIQ1(42,W,.01)
IF (DGW'=0)
IF (W'=DGW)
QUIT
+10 SET ^TMP("ADGWMM",$JOB,W,DGD,DGN)=DFN_U_DGPMCA_U_DGMR_U_DGMD_U_DGPI_U_DGPINM
End DoDot:2
End DoDot:1
+11 ;
+12 DO HDH
DO TMPLP
QUIT
+13 ;
TMPLP ; -- loop thru tmp file
+1 NEW X
+2 ;IHS/DSD/ENM NEXT LINE COPIED/MODIFIED
+3 ;S W=0 F S W=$O(^TMP("ADGWMM",$J,W)) Q:'W!(DGSTOP=U) D
+4 SET W=0
FOR
SET W=$ORDER(^TMP("ADGWMM",$JOB,W))
IF W']""!(DGSTOP=U)
QUIT
Begin DoDot:1
+5 SET DGD=0
FOR
SET DGD=$ORDER(^TMP("ADGWMM",$JOB,W,DGD))
IF 'DGD!(DGSTOP=U)
QUIT
Begin DoDot:2
+6 SET DGN=0
+7 FOR
SET DGN=$ORDER(^TMP("ADGWMM",$JOB,W,DGD,DGN))
IF 'DGN!(DGSTOP=U)
QUIT
Begin DoDot:3
+8 SET DGS=^TMP("ADGWMM",$JOB,W,DGD,DGN)
SET DFN=+DGS
+9 DO PRINT
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
CHECK ; -- check for insurance types requested
+1 SET (DGMD,DGMR,DGPI,DGPINM)=""
+2 IF $DATA(^AUPNMCR("B",DFN))
SET IFN=$ORDER(^(DFN,0))
DO MCR
+3 IF $DATA(^AUPNMCD("B",DFN))
SET IFN=$ORDER(^(DFN,0))
DO MCD
+4 IF $DATA(^AUPNPRVT("B",DFN))
SET IFN=$ORDER(^(DFN,0))
DO INS
+5 QUIT
+6 ;
MCR ; -- medicare
+1 NEW ED,EED
+2 FOR ED=0:0
SET ED=$ORDER(^AUPNMCR(IFN,"11",ED))
IF 'ED
QUIT
Begin DoDot:1
+3 SET EED=$PIECE(^AUPNMCR(IFN,11,ED,0),U,2)
SET DGMR=""
IF EED>DT!('+EED)
Begin DoDot:2
+4 SET DGMR=$PIECE(^AUPNMCR(IFN,0),U,3)_$PIECE(^AUTTMCS($PIECE(^(0),U,4),0),U)
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
MCD ; -- medicaid
+1 NEW ED,EED
+2 FOR ED=0:0
SET ED=$ORDER(^AUPNMCD(IFN,"11",ED))
IF 'ED
QUIT
Begin DoDot:1
+3 SET EED=$PIECE(^AUPNMCD(IFN,11,ED,0),U,2)
SET DGMD=""
+4 IF EED>DT!('+EED)
SET DGMD=$PIECE(^AUPNMCD(IFN,0),U,3)
End DoDot:1
+5 QUIT
+6 ;
INS ; -- private insurance
+1 NEW ED,EED
+2 FOR ED=0:0
SET ED=$ORDER(^AUPNPRVT(IFN,"11",ED))
IF 'ED
QUIT
Begin DoDot:1
+3 SET EED=$PIECE(^AUPNPRVT(IFN,11,ED,0),U,7)
SET DGPI=""
IF EED>DT!('+EED)
Begin DoDot:2
+4 SET DGPI=$PIECE(^AUPNPRVT(IFN,"11",ED,0),U,2)
+5 SET DGPINM=$PIECE(^AUTNINS($PIECE(^AUPNPRVT(IFN,"11",ED,0),U,1),0),U,1)
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
PRINT ; -- print
+1 NEW MR,MD,PV,PVN
+2 IF $Y>(IOSL-6)
DO NEWPG
IF DGSTOP=U
QUIT
+3 ;name
WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,20)
+4 IF $DATA(DUZ(2))&($DATA(^AUPNPAT(DFN,41,DUZ(2),0)))
WRITE ?22,$JUSTIFY($PIECE(^(0),U,2),6)
+5 ;corr admit
SET DGPMCA=$PIECE(DGS,U,2)
+6 ;admission date/time
SET Y=+^DGPM(DGPMCA,0)
XECUTE ^DD("DD")
WRITE ?32,Y
+7 ;dsch date/time
SET Y=DGD
XECUTE ^DD("DD")
WRITE ?50,Y
+8 WRITE ?72,$EXTRACT(W,1,5)
+9 ;admitting Dx
WRITE !?2,"Admit Dx: ",$PIECE(^DGPM(DGPMCA,0),U,10)
+10 SET MR=$PIECE(DGS,U,3)
SET MD=$PIECE(DGS,U,4)
SET PV=$PIECE(DGS,U,5)
SET PVN=$PIECE(DGS,U,6)
+11 IF MD
WRITE ?40,"MCAID #: ",MD
+12 IF MR
WRITE ?61,"MCARE #: ",MR
+13 IF PV
WRITE !?2,"Insurer: ",PVN," #",PV
+14 WRITE !
QUIT
+15 ;
HDH ; -- heading
+1 IF DGPG>0!(IOST["C-")
WRITE @IOF
+2 DO CONF^ADGUTIL(12)
+3 WRITE !?24,"MEDICARE/MEDICAID/INSURANCE LIST"
+4 SET DGPG=DGPG+1
+5 SET Y=DT
XECUTE ^DD("DD")
WRITE ?69,Y
+6 WRITE !?17,"for Discharge Dates: ",$$RANGE
+7 WRITE !?2,"Patient Name",?23,"HRCN",?32,"Admit Date",?50,"Dsch Date"
+8 WRITE ?72,"Ward"
+9 SET LN=""
SET $PIECE(LN,"-",IOM)=""
WRITE !,LN
QUIT
+10 ;
NEWPG ; -- end of page control
+1 IF IOST["C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET DGSTOP=X
IF X=U
QUIT
+2 DO HDH
QUIT
+3 ;
RANGE() ; -- printable date range
+1 NEW X,Y,R
+2 SET Y=DGBD
XECUTE ^DD("DD")
SET R=Y_" to "
+3 SET Y=DGED
XECUTE ^DD("DD")
SET R=R_Y
+4 QUIT R
+5 ;
DWD() ; -- find disch ward
+1 NEW X,Y,Z
SET Y=$GET(^DGPM(+$PIECE(^DGPM(DGPMCA,0),U,17),0))
SET Y=$$IDATE(+Y)
+2 SET X=$ORDER(^DGPM("ATID2",DFN,Y))
+3 IF X>$$IDATE(+^DGPM(DGPMCA,0))
SET Z=DGPMCA
+4 IF X]""
IF '$DATA(Z)
SET Z=$ORDER(^DGPM("ATID2",DFN,X,0))
+5 IF X=""
SET Z=DGPMCA
+6 QUIT $PIECE($GET(^DGPM(+Z,0)),U,6)
+7 ;
IDATE(X) ; -- inverse date
+1 QUIT (9999999.9999999-X)
