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 Sep 23, 2025@20:03:35 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
