- PSULR3 ;BIR/PDW - LAB extract assemble recs. for mail messg. ;25 AUG 1998
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
- EN ;EP
- ;
- ;
- ; Samples of the XTMP records being used
- ;
- ;^XTMP("PSULR_541075670",541075670,"CODES","CV800",4) = CREATININE^mg/dL
- ;^XTMP("PSULR_541075670",541075670,"EVENT",1) = IV^599^13^12345^ASPRIN^CV800
- ;^XTMP("PSULR_541075670",541075670,"PATIENT",13,4) = CREATININE^mg/dL
- ;^XTMP("PSULR_541075670",541075670,"PATIENT",13,4,7029388.859632) = 1.0^^^50
- ;^XTMP("PSULR_541077558",541077558,"RECORDS",59,1) = ^59^^^^12345^^^^^^ASPRIN^^CREATININE^^^^1.0 mg/dL^^6/10/97^
- ;^XTMP("PSULR_541077558",541077558,"SUMMARY",599,13,"CV800",4) = CREATININE^1.0 mg/dL^6/10/97^
- ;
- ; LOOP through the events and assemble records accordingly
- K ^XTMP(PSULRSUB,"RECORDS")
- K ^XTMP(PSULRSUB,"SUMMARY")
- S PSUEV=0 F S PSUEV=$O(^XTMP(PSULRSUB,"EVENT",PSUEV)) Q:PSUEV'>0 S X=^(PSUEV) D
- . ;W !,X
- . S PSUPK=$P(X,U,1),PSUDIV=$P(X,U,2),DFN=$P(X,U,3)
- . S PSUORD=$P(X,U,4),PSUDRGN=$P(X,U,5),PSUDRCD=$P(X,U,6)
- . K PSUCD
- . M PSUCD=^XTMP(PSULRSUB,"CODES",PSUDRCD)
- . S PSUND=0 F S PSUND=$O(PSUCD(PSUND)) Q:PSUND'>0 D
- .. S PSUDT=$O(^XTMP(PSULRSUB,"PATIENT",DFN,PSUND,0))
- .. I 'PSUDT Q ; no test results found
- .. K VA D PID^VADPT
- .. S PSUX=$$RECORD()
- .. K VA
- .. S PSULC=$O(^XTMP(PSULRSUB,"RECORDS",PSUDIV,""),-1)+1
- .. S ^XTMP(PSULRSUB,"RECORDS",PSUDIV,PSULC)=PSUX
- ;
- Q
- ;
- RECORD() ;EP Construct mailing record
- ;3.2.11.42
- K PSUR
- S PSULRDT=9999999-PSUDT
- S X=^XTMP(PSULRSUB,"PATIENT",DFN,PSUND,PSUDT)
- S PSULRF=$S(X["^":$P(X,U,2),1:"") ; hi/low flag
- S PSULRR=$S(X["^":$P(X,U),1:X) ; test result
- S X=^XTMP(PSULRSUB,"PATIENT",DFN,PSUND)
- S PSULRT=$P(X,U) ; Lab Test name stored
- S PSULRU=$P(X,U,2) ; Units stored
- K PSUR
- S PSUR(2)=PSUDIV
- S PSUR(3)=$TR(VA("PID"),"-","")
- S X=$S(PSUPK="IV":4,PSUPK="UD":5,1:10)
- S PSUR(X)=PSUORD
- S PSUR(7)=PSUDRGN
- S PSUR(8)=$P(PSULRT,U)
- S PSUR(9)=PSULRR_" "_PSULRU
- S PSUR(10)=PSULRF
- S PSUR(11)=PSULRDT
- S PSUR=""
- S I=0 F S I=$O(PSUR(I)) Q:I'>0 S PSUR(I)=$TR(PSUR(I),"^","'")
- S I=0 F S I=$O(PSUR(I)) Q:I'>0 S $P(PSUR,U,I)=PSUR(I)
- S PSUR=PSUR_U
- ; Store info for summary by patient
- S PSUTEST=PSULRT_U_PSUR(9)_U_PSULRDT_U_PSULRF ; test^result unit^date^flag
- S ^XTMP(PSULRSUB,"SUMMARY",PSUDIV,DFN,PSUDRCD,PSUND)=PSUTEST
- Q PSUR
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSULR3 2357 printed Feb 18, 2025@23:53:58 Page 2
- PSULR3 ;BIR/PDW - LAB extract assemble recs. for mail messg. ;25 AUG 1998
- +1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
- EN ;EP
- +1 ;
- +2 ;
- +3 ; Samples of the XTMP records being used
- +4 ;
- +5 ;^XTMP("PSULR_541075670",541075670,"CODES","CV800",4) = CREATININE^mg/dL
- +6 ;^XTMP("PSULR_541075670",541075670,"EVENT",1) = IV^599^13^12345^ASPRIN^CV800
- +7 ;^XTMP("PSULR_541075670",541075670,"PATIENT",13,4) = CREATININE^mg/dL
- +8 ;^XTMP("PSULR_541075670",541075670,"PATIENT",13,4,7029388.859632) = 1.0^^^50
- +9 ;^XTMP("PSULR_541077558",541077558,"RECORDS",59,1) = ^59^^^^12345^^^^^^ASPRIN^^CREATININE^^^^1.0 mg/dL^^6/10/97^
- +10 ;^XTMP("PSULR_541077558",541077558,"SUMMARY",599,13,"CV800",4) = CREATININE^1.0 mg/dL^6/10/97^
- +11 ;
- +12 ; LOOP through the events and assemble records accordingly
- +13 KILL ^XTMP(PSULRSUB,"RECORDS")
- +14 KILL ^XTMP(PSULRSUB,"SUMMARY")
- +15 SET PSUEV=0
- FOR
- SET PSUEV=$ORDER(^XTMP(PSULRSUB,"EVENT",PSUEV))
- if PSUEV'>0
- QUIT
- SET X=^(PSUEV)
- Begin DoDot:1
- +16 ;W !,X
- +17 SET PSUPK=$PIECE(X,U,1)
- SET PSUDIV=$PIECE(X,U,2)
- SET DFN=$PIECE(X,U,3)
- +18 SET PSUORD=$PIECE(X,U,4)
- SET PSUDRGN=$PIECE(X,U,5)
- SET PSUDRCD=$PIECE(X,U,6)
- +19 KILL PSUCD
- +20 MERGE PSUCD=^XTMP(PSULRSUB,"CODES",PSUDRCD)
- +21 SET PSUND=0
- FOR
- SET PSUND=$ORDER(PSUCD(PSUND))
- if PSUND'>0
- QUIT
- Begin DoDot:2
- +22 SET PSUDT=$ORDER(^XTMP(PSULRSUB,"PATIENT",DFN,PSUND,0))
- +23 ; no test results found
- IF 'PSUDT
- QUIT
- +24 KILL VA
- DO PID^VADPT
- +25 SET PSUX=$$RECORD()
- +26 KILL VA
- +27 SET PSULC=$ORDER(^XTMP(PSULRSUB,"RECORDS",PSUDIV,""),-1)+1
- +28 SET ^XTMP(PSULRSUB,"RECORDS",PSUDIV,PSULC)=PSUX
- End DoDot:2
- End DoDot:1
- +29 ;
- +30 QUIT
- +31 ;
- RECORD() ;EP Construct mailing record
- +1 ;3.2.11.42
- +2 KILL PSUR
- +3 SET PSULRDT=9999999-PSUDT
- +4 SET X=^XTMP(PSULRSUB,"PATIENT",DFN,PSUND,PSUDT)
- +5 ; hi/low flag
- SET PSULRF=$SELECT(X["^":$PIECE(X,U,2),1:"")
- +6 ; test result
- SET PSULRR=$SELECT(X["^":$PIECE(X,U),1:X)
- +7 SET X=^XTMP(PSULRSUB,"PATIENT",DFN,PSUND)
- +8 ; Lab Test name stored
- SET PSULRT=$PIECE(X,U)
- +9 ; Units stored
- SET PSULRU=$PIECE(X,U,2)
- +10 KILL PSUR
- +11 SET PSUR(2)=PSUDIV
- +12 SET PSUR(3)=$TRANSLATE(VA("PID"),"-","")
- +13 SET X=$SELECT(PSUPK="IV":4,PSUPK="UD":5,1:10)
- +14 SET PSUR(X)=PSUORD
- +15 SET PSUR(7)=PSUDRGN
- +16 SET PSUR(8)=$PIECE(PSULRT,U)
- +17 SET PSUR(9)=PSULRR_" "_PSULRU
- +18 SET PSUR(10)=PSULRF
- +19 SET PSUR(11)=PSULRDT
- +20 SET PSUR=""
- +21 SET I=0
- FOR
- SET I=$ORDER(PSUR(I))
- if I'>0
- QUIT
- SET PSUR(I)=$TRANSLATE(PSUR(I),"^","'")
- +22 SET I=0
- FOR
- SET I=$ORDER(PSUR(I))
- if I'>0
- QUIT
- SET $PIECE(PSUR,U,I)=PSUR(I)
- +23 SET PSUR=PSUR_U
- +24 ; Store info for summary by patient
- +25 ; test^result unit^date^flag
- SET PSUTEST=PSULRT_U_PSUR(9)_U_PSULRDT_U_PSULRF
- +26 SET ^XTMP(PSULRSUB,"SUMMARY",PSUDIV,DFN,PSUDRCD,PSUND)=PSUTEST
- +27 QUIT PSUR