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