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

ADGWMM2.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. LDT ;EP; -- loop by disch date
  1.  K ^TMP("ADGWMM",$J)
  1.  NEW DGD,END,DGN
  1.  S DGD=DGBD-.0001,END=DGED+.2400
  1.  F  S DGD=$O(^DGPM("ATT3",DGD)) Q:'DGD!(DGD>END)  D
  1.  . S DGN=0 F  S DGN=$O(^DGPM("ATT3",DGD,DGN)) Q:'DGN  D
  1.  .. S DFN=$P(^DGPM(DGN,0),U,3),DGPMCA=$P(^(0),U,14)
  1.  .. D CHECK I DGMR="",DGMD="",DGPI="" Q
  1.  .. S W=$$DWD
  1.  .. S W=$$VAL^XBDIQ1(42,W,.01) I (DGW'=0),(W'=DGW) Q
  1.  .. S ^TMP("ADGWMM",$J,W,DGD,DGN)=DFN_U_DGPMCA_U_DGMR_U_DGMD_U_DGPI_U_DGPINM
  1.  ;
  1.  D HDH,TMPLP Q
  1.  ;
  1. TMPLP ; -- loop thru tmp file
  1.  NEW X
  1.  ;IHS/DSD/ENM NEXT LINE COPIED/MODIFIED
  1.  ;S W=0 F  S W=$O(^TMP("ADGWMM",$J,W)) Q:'W!(DGSTOP=U)  D
  1.  S W=0 F  S W=$O(^TMP("ADGWMM",$J,W)) Q:W']""!(DGSTOP=U)  D
  1.  . S DGD=0 F  S DGD=$O(^TMP("ADGWMM",$J,W,DGD)) Q:'DGD!(DGSTOP=U)  D
  1.  .. S DGN=0
  1.  .. F  S DGN=$O(^TMP("ADGWMM",$J,W,DGD,DGN)) Q:'DGN!(DGSTOP=U)  D
  1.  ... S DGS=^TMP("ADGWMM",$J,W,DGD,DGN),DFN=+DGS
  1.  ... D PRINT
  1.  Q
  1.  ;
  1. CHECK ; -- check for insurance types requested
  1.  S (DGMD,DGMR,DGPI,DGPINM)=""
  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.  Q
  1.  ;
  1. MCR ; -- medicare
  1.  NEW ED,EED
  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),DGMR="" I EED>DT!('+EED) D
  1.  .. S DGMR=$P(^AUPNMCR(IFN,0),U,3)_$P(^AUTTMCS($P(^(0),U,4),0),U)
  1.  Q
  1.  ;
  1. MCD ; -- medicaid
  1.  NEW ED,EED
  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),DGMD=""
  1.  . I EED>DT!('+EED) S DGMD=$P(^AUPNMCD(IFN,0),U,3)
  1.  Q
  1.  ;
  1. INS ; -- private insurance 
  1.  NEW ED,EED
  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),DGPI="" I EED>DT!('+EED) D
  1.  .. S DGPI=$P(^AUPNPRVT(IFN,"11",ED,0),U,2)
  1.  .. S DGPINM=$P(^AUTNINS($P(^AUPNPRVT(IFN,"11",ED,0),U,1),0),U,1)
  1.  Q
  1.  ;
  1. PRINT ; -- print
  1.  NEW MR,MD,PV,PVN
  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.  S DGPMCA=$P(DGS,U,2) ;corr admit
  1.  S Y=+^DGPM(DGPMCA,0) X ^DD("DD") W ?32,Y  ;admission date/time
  1.  S Y=DGD X ^DD("DD") W ?50,Y ;dsch date/time
  1.  W ?72,$E(W,1,5)
  1.  W !?2,"Admit Dx: ",$P(^DGPM(DGPMCA,0),U,10)  ;admitting Dx
  1.  S MR=$P(DGS,U,3),MD=$P(DGS,U,4),PV=$P(DGS,U,5),PVN=$P(DGS,U,6)
  1.  I MD W ?40,"MCAID #: ",MD
  1.  I MR W ?61,"MCARE #: ",MR
  1.  I PV W !?2,"Insurer: ",PVN,"  #",PV
  1.  W ! Q
  1.  ;
  1. HDH ; -- heading
  1.  I DGPG>0!(IOST["C-") W @IOF
  1.  D CONF^ADGUTIL(12)
  1.  W !?24,"MEDICARE/MEDICAID/INSURANCE LIST"
  1.  S DGPG=DGPG+1
  1.  S Y=DT X ^DD("DD") W ?69,Y
  1.  W !?17,"for Discharge Dates: ",$$RANGE
  1.  W !?2,"Patient Name",?23,"HRCN",?32,"Admit Date",?50,"Dsch Date"
  1.  W ?72,"Ward"
  1.  S LN="",$P(LN,"-",IOM)="" W !,LN Q
  1.  ;
  1. NEWPG ; -- end of page control
  1.  I IOST["C-" K DIR S DIR(0)="E" D ^DIR S DGSTOP=X Q:X=U
  1.  D HDH Q
  1.  ;
  1. RANGE() ; -- printable date range
  1.  NEW X,Y,R
  1.  S Y=DGBD X ^DD("DD") S R=Y_" to "
  1.  S Y=DGED X ^DD("DD") S R=R_Y
  1.  Q R
  1.  ;
  1. DWD() ; -- find disch ward
  1.  N X,Y,Z S Y=$G(^DGPM(+$P(^DGPM(DGPMCA,0),U,17),0)),Y=$$IDATE(+Y)
  1.  S X=$O(^DGPM("ATID2",DFN,Y))
  1.  I X>$$IDATE(+^DGPM(DGPMCA,0)) S Z=DGPMCA
  1.  I X]"",'$D(Z) S Z=$O(^DGPM("ATID2",DFN,X,0))
  1.  I X="" S Z=DGPMCA
  1.  Q $P($G(^DGPM(+Z,0)),U,6)
  1.  ;
  1. IDATE(X) ; -- inverse date
  1.  Q (9999999.9999999-X)