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

BWGRVLU.m

Go to the documentation of this file. 
  1. BWGRVLU ; IHS/CMI/LAB - GEN RETR UTILITIES ;06-Oct-2003 15:36;DKM
  1.  ;;2.0;WOMEN'S HEALTH;**6,8,9**;MAY 16, 1996
  1.  ;
  1. RZERO(V,L) ;ep right zero fill
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V=V_"0"
  1.  Q V
  1. LZERO(V,L) ;left zero fill
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
  1.  Q V
  1. LBLK(V,L) ;left blank fill
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
  1.  Q V
  1. MCR(P,D) ;is patient medicare eligible on this date
  1.  NEW BWGRMIFN,BWGRFLG
  1.  S BWGRFLG=0
  1.  I '$D(^DPT(P,0)) G MCRX
  1.  I $P(^DPT(P,0),U,19) G MCRX
  1.  I '$D(^AUPNPAT(P,0)) G MCRX
  1.  I '$D(^AUPNMCR(P,11)) G MCRX
  1.  I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCRX
  1.  S BWGRMIFN=0 F  S BWGRMIFN=$O(^AUPNMCR(P,11,BWGRMIFN)) Q:BWGRMIFN'=+BWGRMIFN  D
  1.  .Q:$P(^AUPNMCR(P,11,BWGRMIFN,0),U)>D
  1.  .I $P(^AUPNMCR(P,11,BWGRMIFN,0),U,2)]"",$P(^(0),U,2)<D Q
  1.  .S BWGRFLG=1
  1.  .Q
  1. MCRX ;
  1.  Q BWGRFLG
  1.  ;
  1. MCD(P,D) ;
  1.  NEW BWGRMIFN,BWGRNIFN,BWGRFLG
  1.  S BWGRFLG=0
  1.  I '$D(^DPT(P,0)) G MCDX
  1.  I $P(^DPT(P,0),U,19) G MCDX
  1.  I '$D(^AUPNPAT(P,0)) G MCDX
  1.  I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCDX
  1.  S BWGRMIFN=0 F  S BWGRMIFN=$O(^AUPNMCD("B",P,BWGRMIFN)) Q:BWGRMIFN'=+BWGRMIFN  D
  1.  .Q:'$D(^AUPNMCD(BWGRMIFN,11))
  1.  .S BWGRNIFN=0 F  S BWGRNIFN=$O(^AUPNMCD(BWGRMIFN,11,BWGRNIFN)) Q:BWGRNIFN'=+BWGRNIFN  D
  1.  ..Q:BWGRNIFN>D
  1.  ..I $P(^AUPNMCD(BWGRMIFN,11,BWGRNIFN,0),U,2)]"",$P(^(0),U,2)<D Q
  1.  ..S BWGRFLG=1
  1.  ..Q
  1.  .Q
  1.  ;
  1. MCDX ;
  1.  Q BWGRFLG
  1.  ;
  1. MCDPN(P,D,F) ;EP - return medicaid plan name
  1.  NEW BWGRMIFN,BWGRNIFN,BWGRPN
  1.  S BWGRPN=""
  1.  I '$D(^DPT(P,0)) G MCDPNX
  1.  I $P(^DPT(P,0),U,19) G MCDPNX
  1.  I '$D(^AUPNPAT(P,0)) G MCDPNX
  1.  I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCDPNX
  1.  S BWGRMIFN=0 F  S BWGRMIFN=$O(^AUPNMCD("B",P,BWGRMIFN)) Q:BWGRMIFN'=+BWGRMIFN  D
  1.  .Q:'$D(^AUPNMCD(BWGRMIFN,11))
  1.  .S BWGRNIFN=0 F  S BWGRNIFN=$O(^AUPNMCD(BWGRMIFN,11,BWGRNIFN)) Q:BWGRNIFN'=+BWGRNIFN  D
  1.  ..Q:BWGRNIFN>D
  1.  ..I $P(^AUPNMCD(BWGRMIFN,11,BWGRNIFN,0),U,2)]"",$P(^(0),U,2)<D Q
  1.  ..S BWGRPN=$P(^AUPNMCD(BWGRMIFN,0),U,10) I BWGRPN]"" S BWGRPN=$S(F="E":$P(^AUTNINS(BWGRPN,0),U),1:BWGRPN)
  1.  ..Q
  1.  .Q
  1.  ;
  1. MCDPNX ;
  1.  Q BWGRPN
  1. PI(P,D) ; EP
  1.  NEW BWGRMIFN,BWGRFLG
  1.  S BWGRFLG=0
  1.  I '$D(^DPT(P,0)) G PIX
  1.  I $P(^DPT(P,0),U,19) G PIX
  1.  I '$D(^AUPNPAT(P,0)) G PIX
  1.  I '$D(^AUPNPRVT(P,11)) G PIX
  1.  I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G PIX
  1.  S BWGRMIFN=0 F  S BWGRMIFN=$O(^AUPNPRVT(P,11,BWGRMIFN)) Q:BWGRMIFN'=+BWGRMIFN  D
  1.  .Q:$P(^AUPNPRVT(P,11,BWGRMIFN,0),U)=""
  1.  .S BWGRNAME=$P(^AUPNPRVT(P,11,BWGRMIFN,0),U) Q:BWGRNAME=""
  1.  .Q:$P(^AUTNINS(BWGRNAME,0),U)["AHCCCS"
  1.  .Q:$P(^AUPNPRVT(P,11,BWGRMIFN,0),U,6)>D
  1.  .I $P(^AUPNPRVT(P,11,BWGRMIFN,0),U,7)]"",$P(^(0),U,7)<D Q
  1.  .S BWGRFLG=1
  1.  .Q
  1. PIX ;
  1.  Q BWGRFLG
  1. PIV(P,D) ;EP - return 1 or 0 if current pi policy has been verified, return 1
  1.  NEW BWGRMIFN,BWGRFLG
  1.  S BWGRFLG=0
  1.  I '$D(^DPT(P,0)) G PIX
  1.  I $P(^DPT(P,0),U,19) G PIX
  1.  I '$D(^AUPNPAT(P,0)) G PIX
  1.  I '$D(^AUPNPRVT(P,11)) G PIX
  1.  I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G PIX
  1.  S BWGRMIFN=0 F  S BWGRMIFN=$O(^AUPNPRVT(P,11,BWGRMIFN)) Q:BWGRMIFN'=+BWGRMIFN  D
  1.  .Q:$P(^AUPNPRVT(P,11,BWGRMIFN,0),U)=""
  1.  .S BWGRNAME=$P(^AUPNPRVT(P,11,BWGRMIFN,0),U) Q:BWGRNAME=""
  1.  .Q:$P(^AUTNINS(BWGRNAME,0),U)["AHCCCS"
  1.  .Q:$P(^AUPNPRVT(P,11,BWGRMIFN,0),U,6)>D
  1.  .I $P(^AUPNPRVT(P,11,BWGRMIFN,0),U,7)]"",$P(^(0),U,7)<D Q
  1.  .Q:$P(^AUPNPRVT(P,11,BWGRMIFN,0),U,9)=""
  1.  .S BWGRFLG=1
  1.  .Q
  1. PIVX ;
  1.  Q BWGRFLG
  1.  ;
  1. PIN(P,D,F) ;EP private insurer name (external or internal)
  1.  NEW BWGRMIFN,BWGRPIM
  1.  S:$G(F)="" F="E"
  1.  S BWGRPIN=""
  1.  I '$D(^DPT(P,0)) G PINX
  1.  I $P(^DPT(P,0),U,19) G PINX
  1.  I '$D(^AUPNPAT(P,0)) G PINX
  1.  I '$D(^AUPNPRVT(P,11)) G PINX
  1.  I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G PINX
  1.  S BWGRMIFN=0 F  S BWGRMIFN=$O(^AUPNPRVT(P,11,BWGRMIFN)) Q:BWGRMIFN'=+BWGRMIFN  D
  1.  .Q:$P(^AUPNPRVT(P,11,BWGRMIFN,0),U)=""
  1.  .S BWGRPIN=$P(^AUPNPRVT(P,11,BWGRMIFN,0),U)
  1.  .I $P(^AUTNINS(BWGRPIN,0),U)["AHCCCS" S BWGRPIN="" Q
  1.  .I $P(^AUPNPRVT(P,11,BWGRMIFN,0),U,6)>D S BWGRPIN="" Q
  1.  .I $P(^AUPNPRVT(P,11,BWGRMIFN,0),U,7)]"",$P(^(0),U,7)<D S BWGRPIN="" Q
  1.  .S BWGRPIN=$S(F="E":$P(^AUTNINS(BWGRPIN,0),U),1:BWGRPIN)
  1.  .Q
  1. PINX ;
  1.  Q BWGRPIN
  1. LOS(V) ;EP called from pcc man rpts visit sort
  1.  I 'V Q ""
  1.  I '$D(^AUPNVSIT(V)) Q ""
  1.  I $P(^AUPNVSIT(V,0),U,7)'="H" Q ""
  1.  I $P(^AUPNVSIT(V,0),U,3)="C",'$D(^AUPNVCHS("AD",V)) Q ""
  1.  I $P(^AUPNVSIT(V,0),U,3)'="C",'$D(^AUPNVINP("AD",V)) Q ""
  1.  NEW D,E,F,A
  1.  S A=$P($P(^AUPNVSIT(V,0),U),".")
  1.  S F=$S($D(^AUPNVINP("AD",V)):$O(^AUPNVINP("AD",V,0)),$D(^AUPNVCHS("AD",V)):$O(^AUPNVCHS("AD",V,0)),1:"")
  1.  I F="" Q F
  1.  S D=$S($D(^AUPNVINP("AD",V)):$P(^AUPNVINP(F,0),U),$D(^AUPNVCHS("AD",V)):$P(^AUPNVCHS(F,0),U,12),1:"")
  1.  I D="" Q D
  1.  S E=$$FMDIFF^XLFDT(D,A,1)
  1.  Q $S('E:1,1:E)
  1. THIRD ;EP
  1.  S BWGRPRNT=""
  1.  S X=$$MCR^AUPNPAT(DFN,$S(BWGRPTVS="R":$P(BWGRVREC,U),1:DT)) S:X BWGRPRNT=BWGRPRNT_"MEDICARE  "
  1.  S X=$$MCD^AUPNPAT(DFN,$S(BWGRPTVS="R":$P(BWGRVREC,U),1:DT)) S:X BWGRPRNT=BWGRPRNT_"MEDICAID  "
  1.  S X=$$PI^AUPNPAT(DFN,$S(BWGRPTVS="R":$P(BWGRVREC,U),1:DT)) S:X BWGRPRNT=BWGRPRNT_"PRVT INS  "
  1.  S:BWGRPRNT="" BWGRPRNT="<none>"
  1.  Q
  1. XTMP(N,D) ;EP - set xtmp 0 node
  1.  Q:$G(N)=""
  1.  S ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_$G(D)
  1.  Q
  1. PROC ;EP
  1.  NEW BWGRZ,BWGRY,BWGRP
  1.  S BWGRZ=0 F  S BWGRZ=$O(^BWPCD("C",DFN,BWGRZ)) Q:BWGRZ=""  D
  1.  .S BWGRY=$P(^BWPCD(BWGRZ,0),U,12)
  1.  .Q:BWGRY<BWGRBD
  1.  .Q:BWGRY>BWGRED
  1.  .Q:$P(^BWPCD(BWGRZ,0),U,4)=""
  1.  .S X($P(^BWPCD(BWGRZ,0),U,4))=""
  1.  .Q
  1.  K BWGRZ,BWGRY,BWGRP
  1.  Q
  1. CALC ;ENTRY POINT
  1.  I Y=0!(X=0) S Z="**" G COMMA
  1.  S Z=(((X/Y)-1)*100),Z=$FN(Z,"+,",1)
  1. COMMA ;
  1.  S X=$FN(X,",")
  1.  ;S X2=0,X3=$S($L(X)>3:($L(X)+($L(X)\3)),1:$L(X)) D COMMA^%DTC S X=$E(X,1,($L(X)-1))
  1.  Q
  1. DONE ;ENTRY POINT - END OF REPORT TIME DISPLAY
  1.  I $D(BWGRET) S BWGRTS=(86400*($P(BWGRET,",")-$P(BWGRBT,",")))+($P(BWGRET,",",2)-$P(BWGRBT,",",2)),BWGRH=$P(BWGRTS/3600,".") S:BWGRH="" BWGRH=0 D
  1.  .S BWGRTS=BWGRTS-(BWGRH*3600),BWGRM=$P(BWGRTS/60,".") S:BWGRM="" BWGRM=0 S BWGRTS=BWGRTS-(BWGRM*60),BWGRS=BWGRTS W !!,"RUN TIME (H.M.S): ",BWGRH,".",BWGRM,".",BWGRS
  1.  I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of report.  HIT RETURN" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  W:$D(IOF) @IOF
  1.  K BWGRTS,BWGRS,BWGRH,BWGRM,BWGRET
  1.  Q
  1.  ; Print Notifications Types that contain the TXT value in their name
  1.  ; VIEN = Represents either Patient or Procedure IEN dependent upon report context
  1.  ; TXT = Notification Type must contain this text if present
  1.  ; PRM = 0= just time, 1=time and date, 2=time, date, and type
  1. NOTIFP(VIEN,TXT,PRM) ;
  1.  N NIEN,XRF,LP
  1.  S TXT=$G(TXT,""),PRM=$G(PRM,0)
  1.  I BWGRPTVS="P" D
  1.  .; Process patient
  1.  .S XRF="B"
  1.  .S LP=VIEN
  1.  E  D
  1.  .; Process procedure
  1.  .S XRF="C"
  1.  .S LP=$$GET1^DIQ(9002086.1,VIEN,.01,"I")
  1.  S NIEN=0 F  S NIEN=$O(^BWNOT(XRF,LP,NIEN)) Q:NIEN=""  D
  1.  .D ADDNOTIF(NIEN,TXT,PRM)
  1.  Q
  1. ADDNOTIF(NIEN,TXT,PRM) ; Add notification to array
  1.  N NTYP,VAL
  1.  S NTYP=$$GET1^DIQ(9002086.4,NIEN,.03,"E")
  1.  ; Check to see if notification types have been restricted
  1.  Q:($L(TXT)&(NTYP'[TXT))
  1.  S VAL=$$GET1^DIQ(9002086.4,NIEN,.15,"I")
  1.  S:PRM>0 VAL=VAL_"  "_$$FMTE^XLFDT($$GET1^DIQ(9002086.4,NIEN,.02,"I"),"5ZD")
  1.  S:PRM>1 VAL=VAL_"  "_NTYP
  1.  S BWGRPCNT=$G(BWGRPCNT)+1,BWGRPRNM(BWGRPCNT)=VAL
  1.  Q
  1.  ; Time Required Notification Screen
  1.  ; VIEN = Represents either Patient or Procedure IEN dependent upon report context
  1.  ; TXT = Notification Type must contain this text if present
  1.  ;
  1. NOTIFS(VIEN,TXT) ;
  1.  N NIEN,XRF,LP,TM,RVAL1,RVAL2
  1.  S TXT=$G(TXT,"")
  1.  I BWGRPTVS="P" D
  1.  .; Process patient
  1.  .S XRF="B"
  1.  .S LP=VIEN
  1.  E  D
  1.  .; Process procedure
  1.  .S XRF="C"
  1.  .S LP=$$GET1^DIQ(9002086.1,VIEN,.01,"I")
  1.  S NIEN=0 F  S NIEN=$O(^BWNOT(XRF,LP,NIEN)) Q:NIEN=""  D
  1.  .S RVAL1=$P(^BWGRTRPT(BWGRRPT,11,BWGRI,11,1,0),U),RVAL2=$P(^(0),U,2)
  1.  .S TM=$$GET1^DIQ(9002086.4,NIEN,.15,"I")
  1.  .Q:RVAL1>TM!(X>RVAL2)
  1.  .S X(RVAL1)=""
  1.  Q