PSULR2 ;BIR/PDW - PBM LAB EXTRACT PROCESS PATIENTS ;25 AUG 1998
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
;
;DBIA'S
; Reference to file #2 supported by DBIA 10035
; Reference to file #63 supported by DBIA 2524
;
EN ;EP SCAN AND SPLIT INTO DIVISION,RECORDS
; Build ^XTMP(,,"RECORDS",PSUDIV,L)
; Build ^XTMP(,,"PATIENT",DFN,TEST)="" AND THEN
; ,DATE)=RESULT^FLAG
K ^XTMP(PSULRSUB,"RECORDS"),^("PATIENTS")
; Gather the tests necessary for each patient
S PSUDA="" F S PSUDA=$O(^XTMP(PSULRSUB,"EVENT",PSUDA)) Q:PSUDA'>0 S X=^(PSUDA) D TESTS
;
; with the tests gathered for each patient
; now scan each patients daily lab results looking for the tests
D PATIENT
Q
TESTS ;EP Gather tests for a patient for the drug class
; nodes used in ^XTMP sampler
;^XTMP("PSULR_541074170","CODES","CV800",6) = POTASSIUM
;^XTMP("PSULR_541074170","EVENT",1) = IV^599^13^12345^ASPRIN^CV800
;^XTMP("PSULR_541074170","PATIENT",13,4) = CREATININE
;^XTMP("PSULR_541074170","PATIENT",13,4,7029388.859632) = 1.0^^^50
;^XTMP("PSULR_541074170","PATIENT",13,6) = POTASSIUM
;^XTMP("PSULR_541074170","PATIENT",13,6,7029388.859632) = 5.0^^^50
;
; lab test "ch" node locations for each drug class were built in PSULR1
; Setup "Patient",ch node)="" by codes and tests built in XTMP(,,"CODES",TEST node)=test name
;
S PSUDRCD=$P(X,U,6),PSUDFN=$P(X,U,3)
S PSULRND=0 F S PSULRND=$O(^XTMP(PSULRSUB,"CODES",PSUDRCD,PSULRND)) Q:PSULRND'>0 S X=^(PSULRND) D
. S ^XTMP(PSULRSUB,"PATIENT",PSUDFN,PSULRND)=X
Q
;
PATIENT ;EP SCAN for each patient their tests needed
;Take ^XTMP(,"PATIENT","CH TEST NODE")=TESTNAME
;scan the lab file
;and build
; ^XTMP(,"PATIENT","CH TEST NODE",DATE)=RESULT^TESTFLAG
;
S X1=PSUEDT,X2=-365 D C^%DTC
;S X1=PSUSDT,X2=-365 D C^%DTC
S PSULREDT=9999999-X ; only go back one year
S PSULRSDT=9999999-PSUSDT
;
; gather needed test (nodes) from ^XTMP and put into the X to PSUNODE array
;
S DFN=0 F K X S DFN=$O(^XTMP(PSULRSUB,"PATIENT",DFN)) Q:DFN'>0 M X=^(DFN) D
. N PSUNODE
. ; psunode("CH" NODE)=test name
. M PSUNODE=X
. I '$D(^DPT(DFN,"LR")) Q
. S PSULRDFN=^DPT(DFN,"LR")
. S DA=PSULRSDT F S DA=$O(^LR(PSULRDFN,"CH",DA)) Q:DA'>0 Q:'$D(PSUNODE) Q:DA>PSULREDT D
.. ; check each date for each ch node in PSUNODE
.. S Y=0 F S Y=$O(PSUNODE(Y)) Q:Y'>0 I $D(^LR(PSULRDFN,"CH",DA,Y)) D
... ;found a test, save result & quit testing for the node
... I '$P(^LR(PSULRDFN,"CH",DA,0),U,3) Q ; results not verified
... S ^XTMP(PSULRSUB,"PATIENT",DFN,Y,DA)=^LR(PSULRDFN,"CH",DA,Y)
... K PSUNODE(Y)
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSULR2 2684 printed Apr 09, 2024@21:30:58 Page 2
PSULR2 ;BIR/PDW - PBM LAB EXTRACT PROCESS PATIENTS ;25 AUG 1998
+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 #63 supported by DBIA 2524
+6 ;
EN ;EP SCAN AND SPLIT INTO DIVISION,RECORDS
+1 ; Build ^XTMP(,,"RECORDS",PSUDIV,L)
+2 ; Build ^XTMP(,,"PATIENT",DFN,TEST)="" AND THEN
+3 ; ,DATE)=RESULT^FLAG
+4 KILL ^XTMP(PSULRSUB,"RECORDS"),^("PATIENTS")
+5 ; Gather the tests necessary for each patient
+6 SET PSUDA=""
FOR
SET PSUDA=$ORDER(^XTMP(PSULRSUB,"EVENT",PSUDA))
if PSUDA'>0
QUIT
SET X=^(PSUDA)
DO TESTS
+7 ;
+8 ; with the tests gathered for each patient
+9 ; now scan each patients daily lab results looking for the tests
+10 DO PATIENT
+11 QUIT
TESTS ;EP Gather tests for a patient for the drug class
+1 ; nodes used in ^XTMP sampler
+2 ;^XTMP("PSULR_541074170","CODES","CV800",6) = POTASSIUM
+3 ;^XTMP("PSULR_541074170","EVENT",1) = IV^599^13^12345^ASPRIN^CV800
+4 ;^XTMP("PSULR_541074170","PATIENT",13,4) = CREATININE
+5 ;^XTMP("PSULR_541074170","PATIENT",13,4,7029388.859632) = 1.0^^^50
+6 ;^XTMP("PSULR_541074170","PATIENT",13,6) = POTASSIUM
+7 ;^XTMP("PSULR_541074170","PATIENT",13,6,7029388.859632) = 5.0^^^50
+8 ;
+9 ; lab test "ch" node locations for each drug class were built in PSULR1
+10 ; Setup "Patient",ch node)="" by codes and tests built in XTMP(,,"CODES",TEST node)=test name
+11 ;
+12 SET PSUDRCD=$PIECE(X,U,6)
SET PSUDFN=$PIECE(X,U,3)
+13 SET PSULRND=0
FOR
SET PSULRND=$ORDER(^XTMP(PSULRSUB,"CODES",PSUDRCD,PSULRND))
if PSULRND'>0
QUIT
SET X=^(PSULRND)
Begin DoDot:1
+14 SET ^XTMP(PSULRSUB,"PATIENT",PSUDFN,PSULRND)=X
End DoDot:1
+15 QUIT
+16 ;
PATIENT ;EP SCAN for each patient their tests needed
+1 ;Take ^XTMP(,"PATIENT","CH TEST NODE")=TESTNAME
+2 ;scan the lab file
+3 ;and build
+4 ; ^XTMP(,"PATIENT","CH TEST NODE",DATE)=RESULT^TESTFLAG
+5 ;
+6 SET X1=PSUEDT
SET X2=-365
DO C^%DTC
+7 ;S X1=PSUSDT,X2=-365 D C^%DTC
+8 ; only go back one year
SET PSULREDT=9999999-X
+9 SET PSULRSDT=9999999-PSUSDT
+10 ;
+11 ; gather needed test (nodes) from ^XTMP and put into the X to PSUNODE array
+12 ;
+13 SET DFN=0
FOR
KILL X
SET DFN=$ORDER(^XTMP(PSULRSUB,"PATIENT",DFN))
if DFN'>0
QUIT
MERGE X=^(DFN)
Begin DoDot:1
+14 NEW PSUNODE
+15 ; psunode("CH" NODE)=test name
+16 MERGE PSUNODE=X
+17 IF '$DATA(^DPT(DFN,"LR"))
QUIT
+18 SET PSULRDFN=^DPT(DFN,"LR")
+19 SET DA=PSULRSDT
FOR
SET DA=$ORDER(^LR(PSULRDFN,"CH",DA))
if DA'>0
QUIT
if '$DATA(PSUNODE)
QUIT
if DA>PSULREDT
QUIT
Begin DoDot:2
+20 ; check each date for each ch node in PSUNODE
+21 SET Y=0
FOR
SET Y=$ORDER(PSUNODE(Y))
if Y'>0
QUIT
IF $DATA(^LR(PSULRDFN,"CH",DA,Y))
Begin DoDot:3
+22 ;found a test, save result & quit testing for the node
+23 ; results not verified
IF '$PIECE(^LR(PSULRDFN,"CH",DA,0),U,3)
QUIT
+24 SET ^XTMP(PSULRSUB,"PATIENT",DFN,Y,DA)=^LR(PSULRDFN,"CH",DA,Y)
+25 KILL PSUNODE(Y)
End DoDot:3
End DoDot:2
End DoDot:1
+26 ;
+27 QUIT
+28 ;
