ADGWMM1 ; IHS/ADC/PDW/ENM - WARD MEDICARE/MEDICAID PRINT ; [ 09/26/2000 8:42 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;**5**;MAR 25, 1999
;
WONE ;EP; -- one ward, current inpts
D INIT,HDH,LDFN,Q Q
;
WALL ;EP; -- all wards, current inpts
D INIT,LWRD,Q Q
;
DATE ;EP; -- by discharge date
D INIT,LDT^ADGWMM2,Q Q
;
;
INIT ; -- initialize variables
U IO S DGSTOP="",DGPG=0
Q
;
LWRD ; -- loop wards (current inpatients)
S DGW="" F S DGW=$O(^DPT("CN",DGW)) Q:DGW=""!(DGSTOP=U) D NEWPG,LDFN
Q
;
LDFN ; -- loop patients & check for medicaid/care
F DFN=0:0 S DFN=$O(^DPT("CN",DGW,DFN)) Q:'DFN!(DGSTOP=U) D
. S (DGMCDN,DGMCRN,DGINSN)=""
. 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 (DGMCDN]"")!(DGMCRN]"")!(DGINSN]"") D PRINT
Q
;
Q ; -- cleanup
I DGSTOP="",IOST["C-" D PRTOPT^ADGVAR
D ^%ZISC
K W,R,I,D,MCRN,MCDN,INSNM,INSN,ED,EED,DFN,IFN,X,Y,DIC,DIC(0),T,LN
K DGMCDN,DGMCRN,DGINSN,DGW,DGBD,DGED,DGMD,DGMR,DGPI,DGPG,DGSTOP
K DGPINM,DGPMCA,DGS,DGT,DGINSNM
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),DGMCRN="" I EED>DT!('+EED) D
.. S DGMCRN=$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),DGMCDN=""
. I EED>DT!('+EED) S DGMCDN=$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),DGINSN="" I EED>DT!('+EED) D
.. S DGINSN=$P(^AUPNPRVT(IFN,"11",ED,0),U,2)
.. S DGINSNM=$P(^AUTNINS($P(^AUPNPRVT(IFN,"11",ED,0),U,1),0),U,1)
Q
;
SWRD ; -- select ward
S DIC=42,DIC(0)="AEMQ" D ^DIC Q:Y<1 S DGW=$P(Y,U,2)
D ZIS G:POP!($D(IO("Q"))) Q
D HDH,LDFN Q
;
PRINT ; -- print
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)
W:$D(^DPT(DFN,.101)) ?30,^(.101) ;room-bed
W:$D(^DPT(DFN,.103)) ?39,$P(^DIC(45.7,^(.103),0),U,3) ;t.s.
W:$D(^DPT(DFN,.104)) ?47,$E($P(^VA(200,^(.104),0),U),1,15) ;provider
S AD=^DPT("CN",DGW,DFN) ;admission IFN
S Y=+^DGPM(AD,0) X ^DD("DD") W ?67,$P(Y,"@") ;admission date/time
W !?2,"Admit Dx: ",$P(^DGPM(AD,0),U,10) ;admitting Dx
;IHS/ASDST/POC/ENM 09/26/00 NEXT 3 LINES COPIED/MOD
;I DGMCDN W ?40,"MCAID #: ",DGMCDN
I DGMCDN]"" W ?40,"MCAID #: ",DGMCDN
;I DGMCRN W ?60,"MCARE #: ",DGMCRN
I DGMCRN]"" W ?60,"MCARE #: ",DGMCRN
;I DGINSN W !?2,"Insurer: ",DGINSNM," #",DGINSN
I DGINSN]"" W !?2,"Insurer: ",DGINSNM," #",DGINSN
W ! Q
;
HDH ; -- heading
I DGPG>0!(IOST["C-") W @IOF
D CONF^ADGUTIL(12)
W !?20,"MEDICARE/MEDICAID/INSURANCE LIST"
S DGPG=DGPG+1
S Y=DT X ^DD("DD") W ?69,Y
W !?20,"CURRENT INPATIENTS ON WARD: ",DGW
W !?2,"Patient Name",?23,"HRCN",?30,"Room",?39,"Srv"
W ?47,"Provider",?67,"Admit Date"
S LN="",$P(LN,"-",IOM)="" W !,LN Q
;
NEWPG ; -- end of page control
I IOST["C-",DGPG>0 K DIR S DIR(0)="E" D ^DIR S DGSTOP=X Q:X=U
D HDH Q
;
ZIS ; -- select device
S %ZIS="PQ" D ^%ZIS G:POP Q I $D(IO("Q")) D TM
Q
;
TM ; -- queued outputs
S ZTRTN=$S(T:"QONE^ADGWMM",1:"QALL^ADGWMM")
S ZTIO=ION,ZTDESC="WARD MEDICAID/MEDICARE REPORT"
S:T ZTSAVE("W")="" D ^%ZTLOAD
D HOME^%ZIS G Q
;
QONE ; -- entry point queued one ward
D HDH,LDFN,Q Q
;
QALL ; -- entry point queued all wards
D LWRD,Q Q
ADGWMM1 ; IHS/ADC/PDW/ENM - WARD MEDICARE/MEDICAID PRINT ; [ 09/26/2000 8:42 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**5**;MAR 25, 1999
+2 ;
WONE ;EP; -- one ward, current inpts
+1 DO INIT
DO HDH
DO LDFN
DO Q
QUIT
+2 ;
WALL ;EP; -- all wards, current inpts
+1 DO INIT
DO LWRD
DO Q
QUIT
+2 ;
DATE ;EP; -- by discharge date
+1 DO INIT
DO LDT^ADGWMM2
DO Q
QUIT
+2 ;
+3 ;
INIT ; -- initialize variables
+1 USE IO
SET DGSTOP=""
SET DGPG=0
+2 QUIT
+3 ;
LWRD ; -- loop wards (current inpatients)
+1 SET DGW=""
FOR
SET DGW=$ORDER(^DPT("CN",DGW))
IF DGW=""!(DGSTOP=U)
QUIT
DO NEWPG
DO LDFN
+2 QUIT
+3 ;
LDFN ; -- loop patients & check for medicaid/care
+1 FOR DFN=0:0
SET DFN=$ORDER(^DPT("CN",DGW,DFN))
IF 'DFN!(DGSTOP=U)
QUIT
Begin DoDot:1
+2 SET (DGMCDN,DGMCRN,DGINSN)=""
+3 IF $DATA(^AUPNMCR("B",DFN))
SET IFN=$ORDER(^(DFN,0))
DO MCR
+4 IF $DATA(^AUPNMCD("B",DFN))
SET IFN=$ORDER(^(DFN,0))
DO MCD
+5 IF $DATA(^AUPNPRVT("B",DFN))
SET IFN=$ORDER(^(DFN,0))
DO INS
+6 IF (DGMCDN]"")!(DGMCRN]"")!(DGINSN]"")
DO PRINT
End DoDot:1
+7 QUIT
+8 ;
Q ; -- cleanup
+1 IF DGSTOP=""
IF IOST["C-"
DO PRTOPT^ADGVAR
+2 DO ^%ZISC
+3 KILL W,R,I,D,MCRN,MCDN,INSNM,INSN,ED,EED,DFN,IFN,X,Y,DIC,DIC(0),T,LN
+4 KILL DGMCDN,DGMCRN,DGINSN,DGW,DGBD,DGED,DGMD,DGMR,DGPI,DGPG,DGSTOP
+5 KILL DGPINM,DGPMCA,DGS,DGT,DGINSNM
+6 QUIT
+7 ;
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 DGMCRN=""
IF EED>DT!('+EED)
Begin DoDot:2
+3 SET DGMCRN=$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 DGMCDN=""
+3 IF EED>DT!('+EED)
SET DGMCDN=$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 DGINSN=""
IF EED>DT!('+EED)
Begin DoDot:2
+3 SET DGINSN=$PIECE(^AUPNPRVT(IFN,"11",ED,0),U,2)
+4 SET DGINSNM=$PIECE(^AUTNINS($PIECE(^AUPNPRVT(IFN,"11",ED,0),U,1),0),U,1)
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
SWRD ; -- select ward
+1 SET DIC=42
SET DIC(0)="AEMQ"
DO ^DIC
IF Y<1
QUIT
SET DGW=$PIECE(Y,U,2)
+2 DO ZIS
IF POP!($DATA(IO("Q")))
GOTO Q
+3 DO HDH
DO LDFN
QUIT
+4 ;
PRINT ; -- print
+1 IF $Y>(IOSL-6)
DO NEWPG
IF DGSTOP=U
QUIT
+2 ;name
WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,20)
+3 IF $DATA(DUZ(2))&($DATA(^AUPNPAT(DFN,41,DUZ(2),0)))
WRITE ?22,$JUSTIFY($PIECE(^(0),U,2),6)
+4 ;room-bed
IF $DATA(^DPT(DFN,.101))
WRITE ?30,^(.101)
+5 ;t.s.
IF $DATA(^DPT(DFN,.103))
WRITE ?39,$PIECE(^DIC(45.7,^(.103),0),U,3)
+6 ;provider
IF $DATA(^DPT(DFN,.104))
WRITE ?47,$EXTRACT($PIECE(^VA(200,^(.104),0),U),1,15)
+7 ;admission IFN
SET AD=^DPT("CN",DGW,DFN)
+8 ;admission date/time
SET Y=+^DGPM(AD,0)
XECUTE ^DD("DD")
WRITE ?67,$PIECE(Y,"@")
+9 ;admitting Dx
WRITE !?2,"Admit Dx: ",$PIECE(^DGPM(AD,0),U,10)
+10 ;IHS/ASDST/POC/ENM 09/26/00 NEXT 3 LINES COPIED/MOD
+11 ;I DGMCDN W ?40,"MCAID #: ",DGMCDN
+12 IF DGMCDN]""
WRITE ?40,"MCAID #: ",DGMCDN
+13 ;I DGMCRN W ?60,"MCARE #: ",DGMCRN
+14 IF DGMCRN]""
WRITE ?60,"MCARE #: ",DGMCRN
+15 ;I DGINSN W !?2,"Insurer: ",DGINSNM," #",DGINSN
+16 IF DGINSN]""
WRITE !?2,"Insurer: ",DGINSNM," #",DGINSN
+17 WRITE !
QUIT
+18 ;
HDH ; -- heading
+1 IF DGPG>0!(IOST["C-")
WRITE @IOF
+2 DO CONF^ADGUTIL(12)
+3 WRITE !?20,"MEDICARE/MEDICAID/INSURANCE LIST"
+4 SET DGPG=DGPG+1
+5 SET Y=DT
XECUTE ^DD("DD")
WRITE ?69,Y
+6 WRITE !?20,"CURRENT INPATIENTS ON WARD: ",DGW
+7 WRITE !?2,"Patient Name",?23,"HRCN",?30,"Room",?39,"Srv"
+8 WRITE ?47,"Provider",?67,"Admit Date"
+9 SET LN=""
SET $PIECE(LN,"-",IOM)=""
WRITE !,LN
QUIT
+10 ;
NEWPG ; -- end of page control
+1 IF IOST["C-"
IF DGPG>0
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET DGSTOP=X
IF X=U
QUIT
+2 DO HDH
QUIT
+3 ;
ZIS ; -- select device
+1 SET %ZIS="PQ"
DO ^%ZIS
IF POP
GOTO Q
IF $DATA(IO("Q"))
DO TM
+2 QUIT
+3 ;
TM ; -- queued outputs
+1 SET ZTRTN=$SELECT(T:"QONE^ADGWMM",1:"QALL^ADGWMM")
+2 SET ZTIO=ION
SET ZTDESC="WARD MEDICAID/MEDICARE REPORT"
+3 IF T
SET ZTSAVE("W")=""
DO ^%ZTLOAD
+4 DO HOME^%ZIS
GOTO Q
+5 ;
QONE ; -- entry point queued one ward
+1 DO HDH
DO LDFN
DO Q
QUIT
+2 ;
QALL ; -- entry point queued all wards
+1 DO LWRD
DO Q
QUIT
