PSUDEM2 ;BIR/DAM - Outpatient Visits Extract ;1/23/09 3:10pm
;;4.0;PHARMACY BENEFITS MANAGEMENT;**15,19**;MARCH, 2005;Build 28
;
;DBIA's
; Reference to file 2 supported by DBIA 10035
; Reference to file 9000010.07 supported by DBIA 3094
; Reference to file 9000010 supported by DBIA 3512
; Reference to file 4.3 supported by DBIA 2496
; Reference to file 9000010.18 supported by DBIA 3560
; Reference to file 81 supported by DBIA 2815
; Reference to ICDEX Utility supported by DBIA 5747
EN ;EN Called from PSUCP
K ^XTMP("PSU_"_PSUJOB,"PSUOPV"),^XTMP("PSU_"_PSUJOB,"PSUTMP")
K NONE
NEW CPTDA,CPTNM,ICDXDA,ICDXNM,PSUICN,PSUSSN,PSUSUB,PSUTEDT
NEW PSUVSTDT,PSUX,PSUY,PTSTAT,SEG,VCPTDA,XX,J
D DAT1
I '$D(^XTMP("PSU_"_PSUJOB,"PSUTMP")) D NODATA
D XMD
EX K ^XTMP("PSU_"_PSUJOB,"PSUPDFLAG")
K ^XTMP("PSU_"_PSUJOB,"PSUOPV")
K ^XTMP("PSU_"_PSUJOB,"PSUXMD")
K ^XTMP("PSU_"_PSUJOB,"PSUTMP")
Q
;
;
DAT1 ;Find visits from V POV file that fall within the date range
S PSUTEDT=PSUEDT
S PSUDT=PSUSDT-1,PSUX=9999999-PSUDT,PSUY=9999999-PSUEDT N PSUEDT
S PSUY=PSUSDT-.0001
F S PSUY=$O(^AUPNVSIT("B",PSUY)) Q:PSUY'>0 Q:((PSUY\1)>PSUTEDT) D
. S PSUVIEN=0 F S PSUVIEN=$O(^AUPNVSIT("B",PSUY,PSUVIEN)) Q:$G(PSUVIEN)'>0 D
.. S PSUPT=$$VALI^PSUTL(9000010,PSUVIEN,.05)
.. D DAT2
Q
DAT2 ;
S PSUPOV=0 F S PSUPOV=$O(^AUPNVPOV("AD",PSUVIEN,PSUPOV)) Q:PSUPOV'>0 D
.N PSUVIEN
.S PSUVIEN=$P($G(^AUPNVPOV(PSUPOV,0)),U,3)
.Q:PSUVIEN=""
.Q:$D(^XTMP("PSU"_PSUJOB,"PSUOPV",PSUVIEN)) ; quit if visit psuvien already stored
. D POVS
.S PSUVSTDT=$P($G(^AUPNVSIT(PSUVIEN,0)),U)\1
.S PSUSSN=$P(^DPT(PSUPT,0),U,9)
.S PSUICN=$$GETICN^MPIF001(PSUPT)
.I PSUICN[-1 S PSUICN=""
.;PSU*4*15 Protect from empty 150 nodes
.S PTSTAT=$P($G(^AUPNVSIT(PSUVIEN,150)),U,2),PTSTAT=$S(+PTSTAT:"I",1:"O")
.D SET
Q
POVS ;several POVs can have same visit, work all when the first is found
;N PSUPOV
N PSUPOV,ICDDATA
;PSU*4*15 move kills out of loop.
K ALLICD,ALLICDX,ALLCPT,PSUCSYS
S PSUPOV=0 F S PSUPOV=$O(^AUPNVPOV("AD",PSUVIEN,PSUPOV)) Q:PSUPOV'>0 D
.;LOOP CPTs linked by visit
.S VCPTDA=0 F S VCPTDA=$O(^AUPNVCPT("AD",PSUVIEN,VCPTDA)) Q:VCPTDA'>0 D
..; get/gather cpts
..S CPTDA=$P($G(^AUPNVCPT(VCPTDA,0)),U),CPTNM=$P($G(^ICPT(CPTDA,0)),U) S:$L(CPTNM) ALLCPT(CPTNM)=""
..;get/gather icds
..S PSUXDA=$P($G(^AUPNVCPT(VCPTDA,0)),U,5) I PSUXDA S ICDDATA=$$ICDDX^ICDEX(PSUXDA,,,"I"),ICDXNM=$P(ICDDATA,U,2)
..I $G(ICDXNM)]"" S ALLICDX($S($P(ICDDATA,U,20)=1:"9",$P(ICDDATA,U,20)=30:"10",1:"-null-"),ICDXNM)=""
.;get original icd
.S PSUXDA=$P($G(^AUPNVPOV(PSUPOV,0)),U) I PSUXDA S ICDDATA=$$ICDDX^ICDEX(PSUXDA,,,"I"),ICDXNM=$P(ICDDATA,U,2)
.I $G(ICDXNM)]"" S ALLICDX($S($P(ICDDATA,U,20)=1:"9",$P(ICDDATA,U,20)=30:"10",1:"-null-"),ICDXNM)=""
Q
SET ; Set segment
;Figure Code System for SEG
I $D(ALLICDX("9")),($D(ALLICDX("10"))) S PSUCSYS="U"
I '$D(ALLICDX("9")),($D(ALLICDX("10"))) S PSUCSYS="10"
I $D(ALLICDX("9")),('$D(ALLICDX("10"))) S PSUCSYS="9"
F I="9","10","-null-" S J="" F S J=$O(ALLICDX(I,J)) Q:J="" S ALLICD(J)=""
I '$D(ALLICD),'$D(ALLCPT) Q ;ensure visit has either CPT or ICD
;assemble elements and set
S SEG=U_PSUSNDR_U_PTSTAT_U_PSUVSTDT_U_PSUSSN_U_PSUICN_U
I $D(ALLICD) S ICDXNM="" F I=7:1:16 S ICDXNM=$O(ALLICD(ICDXNM)) Q:ICDXNM="" S $P(SEG,U,I)=ICDXNM
I $D(ALLCPT) S CPTNM="" F J=17:1:26 S CPTNM=$O(ALLCPT(CPTNM)) Q:CPTNM="" S $P(SEG,U,J)=CPTNM
S ($P(SEG,U,27),ICDXNM,CPTNM)=""
S $P(SEG,U,$L(SEG,U))=$G(PSUCSYS,"")
S ^XTMP("PSU_"_PSUJOB,"PSUTMP",PSUVIEN)=SEG
Q
;
XMD ;Format mailman message and send.
S PSUAB=0
F PSUPL=1:1 S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUTMP",PSUAB)) Q:PSUAB'>0 S XX=^(PSUAB) D
. S ^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUPL)=XX
NEW PSUMAX,PSULC,PSUTMC,PSUTLC,PSUMC
S PSUMAX=$$VAL^PSUTL(4.3,1,8.3)
S PSUMAX=$S(PSUMAX="":10000,PSUMAX>10000:10000,1:PSUMAX)
S PSUMC=1,PSUMLC=0
F PSULC=1:1 S X=$G(^XTMP("PSU_"_PSUJOB,"PSUOPV",PSULC)) Q:X="" D
.S PSUMLC=PSUMLC+1
.I PSUMLC>PSUMAX S PSUMC=PSUMC+1,PSUMLC=0,PSULC=PSULC-1 Q ; + message
.I $L(X)<235 S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=X Q
.F I=235:-1:1 S Z=$E(X,I) Q:Z="^"
.S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=$E(X,1,I)
.S PSUMLC=PSUMLC+1
.S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)="*"_$E(X,I+1,999)
;
TLC ; Count Lines sent
S PSUTLC=0
F PSUM=1:1:PSUMC S X=$O(^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,""),-1),PSUTLC=PSUTLC+X
;
F PSUM=1:1:PSUMC D OPV^PSUDEM5
D CONF
Q
CONF ;Construct globals for confirmation message
;
I $G(NONE) S PSUTLC=0
N PSUDIVIS
S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
S PSUSUB="PSU_"_PSUJOB
S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,8,"M")=PSUMC
S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,8,"L")=PSUTLC
Q
;
NODATA ;Generate a 'No data' message if there is no data in the extract
;
S NONE=1
M PSUXMYH=PSUXMYS1
S PSUM=1
S ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,1)="No data to report"
Q
REC ;EN If "^" is contained in any record, replace it with "'"
;
I PSUREC["^" S PSUREC=$TR(PSUREC,"^","'")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUDEM2 5131 printed Dec 13, 2024@02:27:44 Page 2
PSUDEM2 ;BIR/DAM - Outpatient Visits Extract ;1/23/09 3:10pm
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**15,19**;MARCH, 2005;Build 28
+2 ;
+3 ;DBIA's
+4 ; Reference to file 2 supported by DBIA 10035
+5 ; Reference to file 9000010.07 supported by DBIA 3094
+6 ; Reference to file 9000010 supported by DBIA 3512
+7 ; Reference to file 4.3 supported by DBIA 2496
+8 ; Reference to file 9000010.18 supported by DBIA 3560
+9 ; Reference to file 81 supported by DBIA 2815
+10 ; Reference to ICDEX Utility supported by DBIA 5747
EN ;EN Called from PSUCP
+1 KILL ^XTMP("PSU_"_PSUJOB,"PSUOPV"),^XTMP("PSU_"_PSUJOB,"PSUTMP")
+2 KILL NONE
+3 NEW CPTDA,CPTNM,ICDXDA,ICDXNM,PSUICN,PSUSSN,PSUSUB,PSUTEDT
+4 NEW PSUVSTDT,PSUX,PSUY,PTSTAT,SEG,VCPTDA,XX,J
+5 DO DAT1
+6 IF '$DATA(^XTMP("PSU_"_PSUJOB,"PSUTMP"))
DO NODATA
+7 DO XMD
EX KILL ^XTMP("PSU_"_PSUJOB,"PSUPDFLAG")
+1 KILL ^XTMP("PSU_"_PSUJOB,"PSUOPV")
+2 KILL ^XTMP("PSU_"_PSUJOB,"PSUXMD")
+3 KILL ^XTMP("PSU_"_PSUJOB,"PSUTMP")
+4 QUIT
+5 ;
+6 ;
DAT1 ;Find visits from V POV file that fall within the date range
+1 SET PSUTEDT=PSUEDT
+2 SET PSUDT=PSUSDT-1
SET PSUX=9999999-PSUDT
SET PSUY=9999999-PSUEDT
NEW PSUEDT
+3 SET PSUY=PSUSDT-.0001
+4 FOR
SET PSUY=$ORDER(^AUPNVSIT("B",PSUY))
if PSUY'>0
QUIT
if ((PSUY\1)>PSUTEDT)
QUIT
Begin DoDot:1
+5 SET PSUVIEN=0
FOR
SET PSUVIEN=$ORDER(^AUPNVSIT("B",PSUY,PSUVIEN))
if $GET(PSUVIEN)'>0
QUIT
Begin DoDot:2
+6 SET PSUPT=$$VALI^PSUTL(9000010,PSUVIEN,.05)
+7 DO DAT2
End DoDot:2
End DoDot:1
+8 QUIT
DAT2 ;
+1 SET PSUPOV=0
FOR
SET PSUPOV=$ORDER(^AUPNVPOV("AD",PSUVIEN,PSUPOV))
if PSUPOV'>0
QUIT
Begin DoDot:1
+2 NEW PSUVIEN
+3 SET PSUVIEN=$PIECE($GET(^AUPNVPOV(PSUPOV,0)),U,3)
+4 if PSUVIEN=""
QUIT
+5 ; quit if visit psuvien already stored
if $DATA(^XTMP("PSU"_PSUJOB,"PSUOPV",PSUVIEN))
QUIT
+6 DO POVS
+7 SET PSUVSTDT=$PIECE($GET(^AUPNVSIT(PSUVIEN,0)),U)\1
+8 SET PSUSSN=$PIECE(^DPT(PSUPT,0),U,9)
+9 SET PSUICN=$$GETICN^MPIF001(PSUPT)
+10 IF PSUICN[-1
SET PSUICN=""
+11 ;PSU*4*15 Protect from empty 150 nodes
+12 SET PTSTAT=$PIECE($GET(^AUPNVSIT(PSUVIEN,150)),U,2)
SET PTSTAT=$SELECT(+PTSTAT:"I",1:"O")
+13 DO SET
End DoDot:1
+14 QUIT
POVS ;several POVs can have same visit, work all when the first is found
+1 ;N PSUPOV
+2 NEW PSUPOV,ICDDATA
+3 ;PSU*4*15 move kills out of loop.
+4 KILL ALLICD,ALLICDX,ALLCPT,PSUCSYS
+5 SET PSUPOV=0
FOR
SET PSUPOV=$ORDER(^AUPNVPOV("AD",PSUVIEN,PSUPOV))
if PSUPOV'>0
QUIT
Begin DoDot:1
+6 ;LOOP CPTs linked by visit
+7 SET VCPTDA=0
FOR
SET VCPTDA=$ORDER(^AUPNVCPT("AD",PSUVIEN,VCPTDA))
if VCPTDA'>0
QUIT
Begin DoDot:2
+8 ; get/gather cpts
+9 SET CPTDA=$PIECE($GET(^AUPNVCPT(VCPTDA,0)),U)
SET CPTNM=$PIECE($GET(^ICPT(CPTDA,0)),U)
if $LENGTH(CPTNM)
SET ALLCPT(CPTNM)=""
+10 ;get/gather icds
+11 SET PSUXDA=$PIECE($GET(^AUPNVCPT(VCPTDA,0)),U,5)
IF PSUXDA
SET ICDDATA=$$ICDDX^ICDEX(PSUXDA,,,"I")
SET ICDXNM=$PIECE(ICDDATA,U,2)
+12 IF $GET(ICDXNM)]""
SET ALLICDX($SELECT($PIECE(ICDDATA,U,20)=1:"9",$PIECE(ICDDATA,U,20)=30:"10",1:"-null-"),ICDXNM)=""
End DoDot:2
+13 ;get original icd
+14 SET PSUXDA=$PIECE($GET(^AUPNVPOV(PSUPOV,0)),U)
IF PSUXDA
SET ICDDATA=$$ICDDX^ICDEX(PSUXDA,,,"I")
SET ICDXNM=$PIECE(ICDDATA,U,2)
+15 IF $GET(ICDXNM)]""
SET ALLICDX($SELECT($PIECE(ICDDATA,U,20)=1:"9",$PIECE(ICDDATA,U,20)=30:"10",1:"-null-"),ICDXNM)=""
End DoDot:1
+16 QUIT
SET ; Set segment
+1 ;Figure Code System for SEG
+2 IF $DATA(ALLICDX("9"))
IF ($DATA(ALLICDX("10")))
SET PSUCSYS="U"
+3 IF '$DATA(ALLICDX("9"))
IF ($DATA(ALLICDX("10")))
SET PSUCSYS="10"
+4 IF $DATA(ALLICDX("9"))
IF ('$DATA(ALLICDX("10")))
SET PSUCSYS="9"
+5 FOR I="9","10","-null-"
SET J=""
FOR
SET J=$ORDER(ALLICDX(I,J))
if J=""
QUIT
SET ALLICD(J)=""
+6 ;ensure visit has either CPT or ICD
IF '$DATA(ALLICD)
IF '$DATA(ALLCPT)
QUIT
+7 ;assemble elements and set
+8 SET SEG=U_PSUSNDR_U_PTSTAT_U_PSUVSTDT_U_PSUSSN_U_PSUICN_U
+9 IF $DATA(ALLICD)
SET ICDXNM=""
FOR I=7:1:16
SET ICDXNM=$ORDER(ALLICD(ICDXNM))
if ICDXNM=""
QUIT
SET $PIECE(SEG,U,I)=ICDXNM
+10 IF $DATA(ALLCPT)
SET CPTNM=""
FOR J=17:1:26
SET CPTNM=$ORDER(ALLCPT(CPTNM))
if CPTNM=""
QUIT
SET $PIECE(SEG,U,J)=CPTNM
+11 SET ($PIECE(SEG,U,27),ICDXNM,CPTNM)=""
+12 SET $PIECE(SEG,U,$LENGTH(SEG,U))=$GET(PSUCSYS,"")
+13 SET ^XTMP("PSU_"_PSUJOB,"PSUTMP",PSUVIEN)=SEG
+14 QUIT
+15 ;
XMD ;Format mailman message and send.
+1 SET PSUAB=0
+2 FOR PSUPL=1:1
SET PSUAB=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUTMP",PSUAB))
if PSUAB'>0
QUIT
SET XX=^(PSUAB)
Begin DoDot:1
+3 SET ^XTMP("PSU_"_PSUJOB,"PSUOPV",PSUPL)=XX
End DoDot:1
+4 NEW PSUMAX,PSULC,PSUTMC,PSUTLC,PSUMC
+5 SET PSUMAX=$$VAL^PSUTL(4.3,1,8.3)
+6 SET PSUMAX=$SELECT(PSUMAX="":10000,PSUMAX>10000:10000,1:PSUMAX)
+7 SET PSUMC=1
SET PSUMLC=0
+8 FOR PSULC=1:1
SET X=$GET(^XTMP("PSU_"_PSUJOB,"PSUOPV",PSULC))
if X=""
QUIT
Begin DoDot:1
+9 SET PSUMLC=PSUMLC+1
+10 ; + message
IF PSUMLC>PSUMAX
SET PSUMC=PSUMC+1
SET PSUMLC=0
SET PSULC=PSULC-1
QUIT
+11 IF $LENGTH(X)<235
SET ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=X
QUIT
+12 FOR I=235:-1:1
SET Z=$EXTRACT(X,I)
if Z="^"
QUIT
+13 SET ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=$EXTRACT(X,1,I)
+14 SET PSUMLC=PSUMLC+1
+15 SET ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)="*"_$EXTRACT(X,I+1,999)
End DoDot:1
+16 ;
TLC ; Count Lines sent
+1 SET PSUTLC=0
+2 FOR PSUM=1:1:PSUMC
SET X=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,""),-1)
SET PSUTLC=PSUTLC+X
+3 ;
+4 FOR PSUM=1:1:PSUMC
DO OPV^PSUDEM5
+5 DO CONF
+6 QUIT
CONF ;Construct globals for confirmation message
+1 ;
+2 IF $GET(NONE)
SET PSUTLC=0
+3 NEW PSUDIVIS
+4 SET PSUDIVIS=$PIECE(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
+5 SET PSUSUB="PSU_"_PSUJOB
+6 SET ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,8,"M")=PSUMC
+7 SET ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,8,"L")=PSUTLC
+8 QUIT
+9 ;
NODATA ;Generate a 'No data' message if there is no data in the extract
+1 ;
+2 SET NONE=1
+3 MERGE PSUXMYH=PSUXMYS1
+4 SET PSUM=1
+5 SET ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,1)="No data to report"
+6 QUIT
REC ;EN If "^" is contained in any record, replace it with "'"
+1 ;
+2 IF PSUREC["^"
SET PSUREC=$TRANSLATE(PSUREC,"^","'")
+3 QUIT
