ADGDMM ; IHS/ADC/PDW/ENM - DISCHARGE M'CARE/M'CAID PRINT ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
;
N DGIFN,R,I,D,MCRN,MCDN,INSNM,INSN,DGED,DGBD,EED,DFN,IFN,X,Y,LN
A ; -- main
D BD I Y=-1 D Q Q
D ED I Y=-1 D Q Q
D ZIS I POP D Q Q
I $D(IO("Q")) D QUE,Q Q
D HD,L3,PG(0),Q Q
;
BD ; -- beginning date
S %DT="AEQ",%DT("A")="Select beginning date: ",X=""
D ^%DT S DGBD=Y-.001 Q
;
ED ; -- ending date
S %DT="AEQ",%DT("A")="Select ending date: ",X=""
D ^%DT S DGED=Y+.9 Q
;
ZIS ; -- select device
S %ZIS="PQ" D ^%ZIS Q
;
;
L3 ; -- loop discharges
S DGDT=DGBD F S DGDT=$O(^DGPM("AMV3",DGDT)) Q:'DGDT!(DGDT>DGED) D
. S DFN=0 F S DFN=$O(^DGPM("AMV3",DGDT,DFN)) Q:'DFN D
.. S DGIFN=0 F S DGIFN=$O(^DGPM("AMV3",DGDT,DFN,DGIFN)) Q:'DGIFN D 1
Q
;
1 ; -- check for medicaid/care
S (R,D,I)=0
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
I (R!D!I) D PRINT
Q
;
Q ; -- cleanup
W:IO'=IO(0)!($D(IO("S"))) @IOF D ^%ZISC Q
;
MCR ; -- medicare
F ED=0:0 S ED=$O(^AUPNMCR(IFN,"11",ED)) Q:'ED D
. S EED=$P(^AUPNMCR(IFN,11,ED,0),U,2),R=0 I EED>DGDT!('+EED) D
.. S R=1,MCRN=$P(^AUPNMCR(IFN,0),U,3)_$P(^AUTTMCS($P(^(0),U,4),0),U)
Q
;
MCD ; -- medicaid
F ED=0:0 S ED=$O(^AUPNMCD(IFN,"11",ED)) Q:'ED D
. S EED=$P(^AUPNMCD(IFN,11,ED,0),U,2),D=0
. I EED>DGDT!('+EED) S D=1,MCDN=$P(^AUPNMCD(IFN,0),U,3)
Q
;
INS ; -- private insurance
F ED=0:0 S ED=$O(^AUPNPRVT(IFN,"11",ED)) Q:'ED D
. S EED=$P(^AUPNPRVT(IFN,11,ED,0),U,7),I=0 I EED>DGDT!('+EED) D
.. S I=1,INSN=$P(^AUPNPRVT(IFN,"11",ED,0),U,2)
.. S INSNM=$P(^AUTNINS($P(^AUPNPRVT(IFN,"11",ED,0),U,1),0),U,1)
Q
;
PRINT ; -- print
I $Y>(IOSL-6) D PG(1)
W !,$E($P(^DPT(DFN,0),U),1,15) ;name
I $D(DUZ(2))&($D(^AUPNPAT(DFN,41,DUZ(2),0))) W ?17,$J($P(^(0),U,2),6)
I D W ?25,MCDN
I R W ?37,MCRN
I I W ?49,$E(INSNM,1,6)," ",INSN
S Y=+^DGPM(DGIFN,0) X ^DD("DD") W ?68,$P(Y,"@") ;discharge date
W ! Q
;
HDH ; -- heading
U IO W !,"MEDICARE/MEDICAID LIST for Discharges from "
S Y=DGBD+.001 X ^DD("DD") W Y," to " S Y=$P(DGED,".") X ^DD("DD") W Y
W !!,"Patient Name",?19,"HRCN",?25,"MCAID #",?37,"MCARE #"
W ?49,"Insurer /#",?68,"DISCHARGED"
S LN="",$P(LN,"-",IOM)="" W !,LN Q
;
QUE ; -- queued outputs
S ZTRTN="QUE^ADGDMM",ZTIO=ION
S ZTDESC="DISCHARGE MEDICAID/MEDICARE REPORT"
S ZTSAVE("DGBD")="",ZTSAVE("DGED")="" D ^%ZTLOAD D ^%ZISC K ZTSK Q
;
PG(Z) ; -- page
Q:IOST'["C-" W ! N X,Y K DIR S DIR(0)="E" D ^DIR W @IOF D HDH:Z Q
;
HD ;
Q:IOST'["C-" W @IOF D HDH Q
ADGDMM ; IHS/ADC/PDW/ENM - DISCHARGE M'CARE/M'CAID PRINT ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
+3 ;
+4 NEW DGIFN,R,I,D,MCRN,MCDN,INSNM,INSN,DGED,DGBD,EED,DFN,IFN,X,Y,LN
A ; -- main
+1 DO BD
IF Y=-1
DO Q
QUIT
+2 DO ED
IF Y=-1
DO Q
QUIT
+3 DO ZIS
IF POP
DO Q
QUIT
+4 IF $DATA(IO("Q"))
DO QUE
DO Q
QUIT
+5 DO HD
DO L3
DO PG(0)
DO Q
QUIT
+6 ;
BD ; -- beginning date
+1 SET %DT="AEQ"
SET %DT("A")="Select beginning date: "
SET X=""
+2 DO ^%DT
SET DGBD=Y-.001
QUIT
+3 ;
ED ; -- ending date
+1 SET %DT="AEQ"
SET %DT("A")="Select ending date: "
SET X=""
+2 DO ^%DT
SET DGED=Y+.9
QUIT
+3 ;
ZIS ; -- select device
+1 SET %ZIS="PQ"
DO ^%ZIS
QUIT
+2 ;
+3 ;
L3 ; -- loop discharges
+1 SET DGDT=DGBD
FOR
SET DGDT=$ORDER(^DGPM("AMV3",DGDT))
IF 'DGDT!(DGDT>DGED)
QUIT
Begin DoDot:1
+2 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV3",DGDT,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+3 SET DGIFN=0
FOR
SET DGIFN=$ORDER(^DGPM("AMV3",DGDT,DFN,DGIFN))
IF 'DGIFN
QUIT
DO 1
End DoDot:2
End DoDot:1
+4 QUIT
+5 ;
1 ; -- check for medicaid/care
+1 SET (R,D,I)=0
+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 IF (R!D!I)
DO PRINT
+6 QUIT
+7 ;
Q ; -- cleanup
+1 IF IO'=IO(0)!($DATA(IO("S")))
WRITE @IOF
DO ^%ZISC
QUIT
+2 ;
MCR ; -- medicare
+1 FOR ED=0:0
SET ED=$ORDER(^AUPNMCR(IFN,"11",ED))
IF 'ED
QUIT
Begin DoDot:1
+2 SET EED=$PIECE(^AUPNMCR(IFN,11,ED,0),U,2)
SET R=0
IF EED>DGDT!('+EED)
Begin DoDot:2
+3 SET R=1
SET MCRN=$PIECE(^AUPNMCR(IFN,0),U,3)_$PIECE(^AUTTMCS($PIECE(^(0),U,4),0),U)
End DoDot:2
End DoDot:1
+4 QUIT
+5 ;
MCD ; -- medicaid
+1 FOR ED=0:0
SET ED=$ORDER(^AUPNMCD(IFN,"11",ED))
IF 'ED
QUIT
Begin DoDot:1
+2 SET EED=$PIECE(^AUPNMCD(IFN,11,ED,0),U,2)
SET D=0
+3 IF EED>DGDT!('+EED)
SET D=1
SET MCDN=$PIECE(^AUPNMCD(IFN,0),U,3)
End DoDot:1
+4 QUIT
+5 ;
INS ; -- private insurance
+1 FOR ED=0:0
SET ED=$ORDER(^AUPNPRVT(IFN,"11",ED))
IF 'ED
QUIT
Begin DoDot:1
+2 SET EED=$PIECE(^AUPNPRVT(IFN,11,ED,0),U,7)
SET I=0
IF EED>DGDT!('+EED)
Begin DoDot:2
+3 SET I=1
SET INSN=$PIECE(^AUPNPRVT(IFN,"11",ED,0),U,2)
+4 SET INSNM=$PIECE(^AUTNINS($PIECE(^AUPNPRVT(IFN,"11",ED,0),U,1),0),U,1)
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
PRINT ; -- print
+1 IF $Y>(IOSL-6)
DO PG(1)
+2 ;name
WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,15)
+3 IF $DATA(DUZ(2))&($DATA(^AUPNPAT(DFN,41,DUZ(2),0)))
WRITE ?17,$JUSTIFY($PIECE(^(0),U,2),6)
+4 IF D
WRITE ?25,MCDN
+5 IF R
WRITE ?37,MCRN
+6 IF I
WRITE ?49,$EXTRACT(INSNM,1,6)," ",INSN
+7 ;discharge date
SET Y=+^DGPM(DGIFN,0)
XECUTE ^DD("DD")
WRITE ?68,$PIECE(Y,"@")
+8 WRITE !
QUIT
+9 ;
HDH ; -- heading
+1 USE IO
WRITE !,"MEDICARE/MEDICAID LIST for Discharges from "
+2 SET Y=DGBD+.001
XECUTE ^DD("DD")
WRITE Y," to "
SET Y=$PIECE(DGED,".")
XECUTE ^DD("DD")
WRITE Y
+3 WRITE !!,"Patient Name",?19,"HRCN",?25,"MCAID #",?37,"MCARE #"
+4 WRITE ?49,"Insurer /#",?68,"DISCHARGED"
+5 SET LN=""
SET $PIECE(LN,"-",IOM)=""
WRITE !,LN
QUIT
+6 ;
QUE ; -- queued outputs
+1 SET ZTRTN="QUE^ADGDMM"
SET ZTIO=ION
+2 SET ZTDESC="DISCHARGE MEDICAID/MEDICARE REPORT"
+3 SET ZTSAVE("DGBD")=""
SET ZTSAVE("DGED")=""
DO ^%ZTLOAD
DO ^%ZISC
KILL ZTSK
QUIT
+4 ;
PG(Z) ; -- page
+1 IF IOST'["C-"
QUIT
WRITE !
NEW X,Y
KILL DIR
SET DIR(0)="E"
DO ^DIR
WRITE @IOF
IF Z
DO HDH
QUIT
+2 ;
HD ;
+1 IF IOST'["C-"
QUIT
WRITE @IOF
DO HDH
QUIT
