PSUDEM7 ;BIR/DAM - Inpatient PTF Record Extract ;20 DEC 2001
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
;
;DBIA's
; Reference to file 2 supported by DBIA 10035
; Reference to file 4.3 supported by DBIA 2496
; Reference to file 45 supported by DBIA 3511
;
EN ;EN
D DAT
D EN^PSUDEM8 ;Gather ICD9 codes
I '$D(^XTMP("PSU_"_PSUJOB,"PSUIPV")) D NODATA
D XMD
K ^XTMP("PSU_"_PSUJOB,"PSUIPV")
K ^XTMP("PSU_"_PSUJOB,"PSUXMD")
Q
;
DAT ;Find discharge dates that fall within the extract date range
;as well as discharge dates within the 30 days prior to day 1 of
;of the extract date range.
;
S PSUDD=0
F S PSUDD=$O(^DGPT("ADS",PSUDD)) Q:'PSUDD D
.S PSUDDT=$E(PSUDD,1,7)
.S X1=PSUSDT
.S X2=(-30)
.D C^%DTC
.S PSUSDT1=X ;Date 30 days prior to start date
.I (PSUDDT>PSUSDT1)!(PSUDDT=PSUSDT1)&(PSUDDT<PSUEDT)!(PSUDDT=PSUEDT) D
..S ^XTMP("PSU_"_PSUJOB,"PSUDM",PSUDDT)=""
..S PSUIEN=0
..F S PSUIEN=$O(^DGPT("ADS",PSUDD,PSUIEN)) Q:'PSUIEN D
...S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,5)=PSUDDT ;Discharge Date
...N PSUDT
...S PSUDT=$P($G(^DGPT(PSUIEN,0)),U,2)
...S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,4)=$E(PSUDT,1,7) ;Admit date
...D INST^PSUDEM1
...S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,2)=PSUSIT ;SITE
...S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,3)=PSUSIT_PSUIEN ;Unique PTF ID
...D SSNICN
Q
;
SSNICN ;Find patient Admission date, SSN and ICN for inpatient record
;VMP - OIFO BAY PINES;ELR;PSU*3.0*24
;
N PSUPT,PSUICN,PSUICN1
S PSUPT=$P($G(^DGPT(PSUIEN,0)),U) ;Pointer to patient file
;
N PSUREC
I PSUPT D
.S PSUREC=$P($G(^DPT(PSUPT,0)),U,9) D REC D
..S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,6)=PSUREC ;Pt SSN
.S PSUICN=$$GETICN^MPIF001(PSUPT) D
..I PSUICN'[-1 D
...S $P(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,7)=PSUICN ;ICN
Q
;
REC ;If "^" is contained in any record, replace it with (')
;
I PSUREC["^" S PSUREC=$TR(PSUREC,"^","'")
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
;
XMD ;Format mailman message and send.
;
S PSUAB=0,PSUPL=1
F S PSUAB=$O(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUAB)) Q:PSUAB="" D
.M ^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUAB) ;Global numerical order
.S PSUPL=PSUPL+1
;
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,"PSUIPV",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)
;
; 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 PTF^PSUDEM5
D CONF
Q
CONF ;Construct globals for confirmation message
;
;D INST^PSUDEM1
I $G(NONE) S PSUTLC=0
N PSUDIVIS
;S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
S PSUDIVIS=PSUSNDR
S PSUSUB="PSU_"_PSUJOB
S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,9,"M")=PSUMC
S ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,9,"L")=PSUTLC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUDEM7 3512 printed Dec 13, 2024@02:27:48 Page 2
PSUDEM7 ;BIR/DAM - Inpatient PTF Record Extract ;20 DEC 2001
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ;
+3 ;DBIA's
+4 ; Reference to file 2 supported by DBIA 10035
+5 ; Reference to file 4.3 supported by DBIA 2496
+6 ; Reference to file 45 supported by DBIA 3511
+7 ;
EN ;EN
+1 DO DAT
+2 ;Gather ICD9 codes
DO EN^PSUDEM8
+3 IF '$DATA(^XTMP("PSU_"_PSUJOB,"PSUIPV"))
DO NODATA
+4 DO XMD
+5 KILL ^XTMP("PSU_"_PSUJOB,"PSUIPV")
+6 KILL ^XTMP("PSU_"_PSUJOB,"PSUXMD")
+7 QUIT
+8 ;
DAT ;Find discharge dates that fall within the extract date range
+1 ;as well as discharge dates within the 30 days prior to day 1 of
+2 ;of the extract date range.
+3 ;
+4 SET PSUDD=0
+5 FOR
SET PSUDD=$ORDER(^DGPT("ADS",PSUDD))
if 'PSUDD
QUIT
Begin DoDot:1
+6 SET PSUDDT=$EXTRACT(PSUDD,1,7)
+7 SET X1=PSUSDT
+8 SET X2=(-30)
+9 DO C^%DTC
+10 ;Date 30 days prior to start date
SET PSUSDT1=X
+11 IF (PSUDDT>PSUSDT1)!(PSUDDT=PSUSDT1)&(PSUDDT<PSUEDT)!(PSUDDT=PSUEDT)
Begin DoDot:2
+12 SET ^XTMP("PSU_"_PSUJOB,"PSUDM",PSUDDT)=""
+13 SET PSUIEN=0
+14 FOR
SET PSUIEN=$ORDER(^DGPT("ADS",PSUDD,PSUIEN))
if 'PSUIEN
QUIT
Begin DoDot:3
+15 ;Discharge Date
SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,5)=PSUDDT
+16 NEW PSUDT
+17 SET PSUDT=$PIECE($GET(^DGPT(PSUIEN,0)),U,2)
+18 ;Admit date
SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,4)=$EXTRACT(PSUDT,1,7)
+19 DO INST^PSUDEM1
+20 ;SITE
SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,2)=PSUSIT
+21 ;Unique PTF ID
SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,3)=PSUSIT_PSUIEN
+22 DO SSNICN
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
SSNICN ;Find patient Admission date, SSN and ICN for inpatient record
+1 ;VMP - OIFO BAY PINES;ELR;PSU*3.0*24
+2 ;
+3 NEW PSUPT,PSUICN,PSUICN1
+4 ;Pointer to patient file
SET PSUPT=$PIECE($GET(^DGPT(PSUIEN,0)),U)
+5 ;
+6 NEW PSUREC
+7 IF PSUPT
Begin DoDot:1
+8 SET PSUREC=$PIECE($GET(^DPT(PSUPT,0)),U,9)
DO REC
Begin DoDot:2
+9 ;Pt SSN
SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,6)=PSUREC
End DoDot:2
+10 SET PSUICN=$$GETICN^MPIF001(PSUPT)
Begin DoDot:2
+11 IF PSUICN'[-1
Begin DoDot:3
+12 ;ICN
SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUIEN),U,7)=PSUICN
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
REC ;If "^" is contained in any record, replace it with (')
+1 ;
+2 IF PSUREC["^"
SET PSUREC=$TRANSLATE(PSUREC,"^","'")
+3 QUIT
+4 ;
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
+7 ;
XMD ;Format mailman message and send.
+1 ;
+2 SET PSUAB=0
SET PSUPL=1
+3 FOR
SET PSUAB=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUAB))
if PSUAB=""
QUIT
Begin DoDot:1
+4 ;Global numerical order
MERGE ^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUPL)=^XTMP("PSU_"_PSUJOB,"PSUIPV",PSUAB)
+5 SET PSUPL=PSUPL+1
End DoDot:1
+6 ;
+7 NEW PSUMAX,PSULC,PSUTMC,PSUTLC,PSUMC
+8 SET PSUMAX=$$VAL^PSUTL(4.3,1,8.3)
+9 SET PSUMAX=$SELECT(PSUMAX="":10000,PSUMAX>10000:10000,1:PSUMAX)
+10 SET PSUMC=1
SET PSUMLC=0
+11 FOR PSULC=1:1
SET X=$GET(^XTMP("PSU_"_PSUJOB,"PSUIPV",PSULC))
if X=""
QUIT
Begin DoDot:1
+12 SET PSUMLC=PSUMLC+1
+13 ; + message
IF PSUMLC>PSUMAX
SET PSUMC=PSUMC+1
SET PSUMLC=0
SET PSULC=PSULC-1
QUIT
+14 IF $LENGTH(X)<235
SET ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=X
QUIT
+15 FOR I=235:-1:1
SET Z=$EXTRACT(X,I)
if Z="^"
QUIT
+16 SET ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)=$EXTRACT(X,1,I)
+17 SET PSUMLC=PSUMLC+1
+18 SET ^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUMC,PSUMLC)="*"_$EXTRACT(X,I+1,999)
End DoDot:1
+19 ;
+20 ; Count Lines sent
+21 SET PSUTLC=0
+22 FOR PSUM=1:1:PSUMC
SET X=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUXMD",PSUM,""),-1)
SET PSUTLC=PSUTLC+X
+23 ;
+24 FOR PSUM=1:1:PSUMC
DO PTF^PSUDEM5
+25 DO CONF
+26 QUIT
CONF ;Construct globals for confirmation message
+1 ;
+2 ;D INST^PSUDEM1
+3 IF $GET(NONE)
SET PSUTLC=0
+4 NEW PSUDIVIS
+5 ;S PSUDIVIS=$P(^XTMP("PSU_"_PSUJOB,"PSUSITE"),U,1)
+6 SET PSUDIVIS=PSUSNDR
+7 SET PSUSUB="PSU_"_PSUJOB
+8 SET ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,9,"M")=PSUMC
+9 SET ^XTMP(PSUSUB,"CONFIRM",PSUDIVIS,9,"L")=PSUTLC
+10 QUIT
