Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ADGWMM1

ADGWMM1.m

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