- 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 Feb 18, 2025@23:53:46 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