PSUSUM5 ;BIR/DAM - Patient Demographics Summary for IV/UD ; 20 DEC 2001
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
;
EN ;EN CALLED FROM PSUUD0
;
I $D(^XTMP("PSU_"_PSUJOB,"PSUFLAG2"))!$D(^XTMP("PSU_"_PSUJOB,"PSUFLAG3")) K ^XTMP("PSU_"_PSUJOB,"PSUSUMA")
I $D(^XTMP("PSU_"_PSUJOB,"PSUNONE","IV"))&$D(^XTMP("PSU_"_PSUJOB,"PSUNONE","UD")) D Q ;Summary report if there is no data
.D NODATA
.I $D(^XTMP("PSU_"_PSUJOB,"PSUFLAG1"))!$D(^XTMP("PSU_"_PSUJOB,"PSUFLAG2")) K ^XTMP("PSU_"_PSUJOB,"PSUNONE")
;
D DATE
S I=7 ;Line Counter
D UNIQUE
D DIV
D TOTAL
D TAB1^PSUSUM4
D PDSUM^PSUDEM5 ;Mail message
K ^XTMP("PSU_"_PSUJOB,"PSUIVOUT")
K ^XTMP("PSU_"_PSUJOB,"PSUUDIN")
I $D(^XTMP("PSU_"_PSUJOB,"PSUFLAG2")) K ^XTMP("PSU_"_PSUJOB,"PSUSUMA")
K ^XTMP("PSU_"_PSUJOB,"PSUFIN")
K ^XTMP("PSU_"_PSUJOB,"PSUIVSSN")
K ^XTMP("PSU_"_PSUJOB,"PSUIVDIV")
K ^XTMP("PSU_"_PSUJOB,"PSUNEW")
K ^XTMP("PSU_"_PSUJOB,"PSUTOTAL")
K ^XTMP("PSU_"_PSUJOB,"PSUFLAG2")
K ^XTMP("PSU_"_PSUJOB,"PSUFLAG3")
K ^XTMP("PSU_"_PSUJOB,"PSUUDDIV")
;
K ^XTMP("PSU_"_PSUJOB,"PSURXCTA")
Q
;
DATE ;Convert date range of extract to external format
;
D PULL^PSUCP
S %H=$E($H,1,5) ;today's date
D YX^%DTC
N PSUD S PSUD=Y
;
S Y=PSUSDT
D DD^%DT
N PSUS S PSUS=Y
;
S Y=PSUEDT
D DD^%DT
N PSUE S PSUE=Y
;
D IVUDSUM
Q
;
IVUDSUM ;Summary report header
;
S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",1)="PHARMACY INPATIENT (UD & IV) UNIQUE PATIENTS REPORT "_PSUD
S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",2),"-",80)="" ;Separator bar
S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",3)=" "_PSUS_" through "_PSUE
S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",4),"=",80)=""
S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",5)=" UNIQUE"
S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",6),"-",70)=""
Q
;
UNIQUE ;Find Total unique patient number across all divisions
;
N PSUSIT
S PSUSIT=PSUSNDR
;
N PSUIPSUM,PSUOPSUM
I '$D(^XTMP("PSU_"_PSUJOB,"PSUIVIN")) S $P(^XTMP("PSU_"_PSUJOB,"PSUIVIN"),U,1)=0
I '$D(^XTMP("PSU_"_PSUJOB,"PSUUDIN")) S $P(^XTMP("PSU_"_PSUJOB,"PSUUDIN"),U,1)=0
I '$D(^XTMP("PSU_"_PSUJOB,"PSUIVOUT")) S $P(^XTMP("PSU_"_PSUJOB,"PSUIVOUT"),U,1)=0
;
;Create IP unique global. Screen out duplicates
M ^XTMP("PSU_"_PSUJOB,"PSUIPSUM")=^XTMP("PSU_"_PSUJOB,"PSUUDIN")
M ^XTMP("PSU_"_PSUJOB,"PSUIPSUM")=^XTMP("PSU_"_PSUJOB,"PSUIN")
;
S N=1
S PSUSUM=0
F S PSUSUM=$O(^XTMP("PSU_"_PSUJOB,"PSUIPSUM",PSUSUM)) Q:PSUSUM="" D
.S PSUIPSUM=N S N=N+1
;
S PSUOPSUM=$P($G(^XTMP("PSU_"_PSUJOB,"PSUIVOUT")),U,1)
D TAB
Q
;
TAB ;Calculate tab spacing
;
N PSUTB2,PSUTB3,PSUTB4,PSUTB5
;
S PSUTB1=" "
S PSUTB2="Total Inpatients across all divisions:"
S PSUTB3=(64-$L(PSUIPSUM))-$L(PSUTB2)
F S2=1:1:(PSUTB3-1) S PSUTB(S2)=" " D
.S PSUTB1=PSUTB1_PSUTB(S2)
;
S PSUTB6=" "
S PSUTB4="Total Outpatients across all divisions:"
S PSUTB5=(64-$L(PSUOPSUM))-$L(PSUTB4)
F S3=1:1:(PSUTB5-1) S PSUTB(S3)=" " D
.S PSUTB6=PSUTB6_PSUTB(S3)
D TOT
Q
;
TOT ;Set total number of unique in-patients and out-patients into
;summary message
;
S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=PSUTB2_PSUTB1_(PSUIPSUM) S I=I+1
S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=PSUTB4_PSUTB6_(PSUOPSUM) S I=I+1
S $P(^XTMP("PSU_"_PSUJOB,"PSUSUMA",I),"-",70)="" S I=I+1
Q
;
DIV ;Set all divisions from both IV and UD extracts into one global
;
M ^XTMP("PSU_"_PSUJOB,"PSUFIN")=^XTMP("PSU_"_PSUJOB,"PSUDIV1") ;IP division name/SSN
M ^XTMP("PSU_"_PSUJOB,"PSUFIN")=^XTMP("PSU_"_PSUJOB,"PSUDIVUD") ;UD division name/SSN
Q
S E=1 ;Counter for new global
S PSUZ=0
F S PSUZ=$O(^XTMP("PSU_"_PSUJOB,"PSUIVINDIV",PSUZ)) Q:PSUZ="" D
.S ^XTMP("PSU_"_PSUJOB,"PSUNEW",PSUZ,E)=$P($G(^XTMP("PSU_"_PSUJOB,"PSUIVINDIV",PSUZ)),U,1) ;IV
.S E=E+1
;
S PSUZ1=0
F S PSUZ1=$O(^XTMP("PSU_"_PSUJOB,"PSUUDDIV",PSUZ1)) Q:PSUZ1="" D
.S ^XTMP("PSU_"_PSUJOB,"PSUNEW",PSUZ1,E)=$P($G(^XTMP("PSU_"_PSUJOB,"PSUUDDIV",PSUZ1)),U,1)
.S E=E+1
Q
;
;
TOTAL ;Calculate sum of all divisions and set individual division lines
;into summary message
;
S T=1
S PSUDNAM=0
F S PSUDNAM=$O(^XTMP("PSU_"_PSUJOB,"PSUFIN",PSUDNAM)) Q:PSUDNAM="" D
.S PSUNUM1=0
.F S PSUNUM1=$O(^XTMP("PSU_"_PSUJOB,"PSUFIN",PSUDNAM,PSUNUM1)) Q:PSUNUM1="" D
..S ^XTMP("PSU_"_PSUJOB,"PSUTOTAL")=T S T=T+1 ;Set total count
..I $D(^XTMP("PSU_"_PSUJOB,"PSUTOT",PSUDNAM)) D
...S C=C+1
...S ^XTMP("PSU_"_PSUJOB,"PSUTOT",PSUDNAM)=C
..I '$D(^XTMP("PSU_"_PSUJOB,"PSUTOT",PSUDNAM)) D
...S C=1
...S ^XTMP("PSU_"_PSUJOB,"PSUTOT",PSUDNAM)=C
;
S PSUDNAM1=0
N PSUSNUM
F S PSUDNAM1=$O(^XTMP("PSU_"_PSUJOB,"PSUTOT",PSUDNAM1)) Q:PSUDNAM1="" D
.S PSUNUM=$P($G(^XTMP("PSU_"_PSUJOB,"PSUTOT",PSUDNAM1)),U,1)
.D TAB1
.S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=" "_PSUDNAM1_" Division:"_PSUTB6_PSUNUM
.S I=I+1
;
Q
;
TAB1 ;Calculate tab spacing
;
S PSUTB6=" "
S PSUTB7=(59-$L(PSUNUM))-$L(PSUDNAM1)-10
F S2=1:1:(PSUTB7-1) S PSUTB(S2)=" " D
.S PSUTB6=PSUTB6_PSUTB(S2) ;Tab position
Q
;
NODATA ;Summary report line to be sent if there is no data
;
S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",1)="PHARMACY INPATIENT (UD & IV) UNIQUE PATIENTS REPORT"
S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",2)=" "
S ^XTMP("PSU_"_PSUJOB,"PSUSUMA",3)="No data to report"
D PDSUM^PSUDEM5
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUSUM5 5418 printed Apr 09, 2024@21:30:17 Page 2
PSUSUM5 ;BIR/DAM - Patient Demographics Summary for IV/UD ; 20 DEC 2001
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ;
EN ;EN CALLED FROM PSUUD0
+1 ;
+2 IF $DATA(^XTMP("PSU_"_PSUJOB,"PSUFLAG2"))!$DATA(^XTMP("PSU_"_PSUJOB,"PSUFLAG3"))
KILL ^XTMP("PSU_"_PSUJOB,"PSUSUMA")
+3 ;Summary report if there is no data
IF $DATA(^XTMP("PSU_"_PSUJOB,"PSUNONE","IV"))&$DATA(^XTMP("PSU_"_PSUJOB,"PSUNONE","UD"))
Begin DoDot:1
+4 DO NODATA
+5 IF $DATA(^XTMP("PSU_"_PSUJOB,"PSUFLAG1"))!$DATA(^XTMP("PSU_"_PSUJOB,"PSUFLAG2"))
KILL ^XTMP("PSU_"_PSUJOB,"PSUNONE")
End DoDot:1
QUIT
+6 ;
+7 DO DATE
+8 ;Line Counter
SET I=7
+9 DO UNIQUE
+10 DO DIV
+11 DO TOTAL
+12 DO TAB1^PSUSUM4
+13 ;Mail message
DO PDSUM^PSUDEM5
+14 KILL ^XTMP("PSU_"_PSUJOB,"PSUIVOUT")
+15 KILL ^XTMP("PSU_"_PSUJOB,"PSUUDIN")
+16 IF $DATA(^XTMP("PSU_"_PSUJOB,"PSUFLAG2"))
KILL ^XTMP("PSU_"_PSUJOB,"PSUSUMA")
+17 KILL ^XTMP("PSU_"_PSUJOB,"PSUFIN")
+18 KILL ^XTMP("PSU_"_PSUJOB,"PSUIVSSN")
+19 KILL ^XTMP("PSU_"_PSUJOB,"PSUIVDIV")
+20 KILL ^XTMP("PSU_"_PSUJOB,"PSUNEW")
+21 KILL ^XTMP("PSU_"_PSUJOB,"PSUTOTAL")
+22 KILL ^XTMP("PSU_"_PSUJOB,"PSUFLAG2")
+23 KILL ^XTMP("PSU_"_PSUJOB,"PSUFLAG3")
+24 KILL ^XTMP("PSU_"_PSUJOB,"PSUUDDIV")
+25 ;
+26 KILL ^XTMP("PSU_"_PSUJOB,"PSURXCTA")
+27 QUIT
+28 ;
DATE ;Convert date range of extract to external format
+1 ;
+2 DO PULL^PSUCP
+3 ;today's date
SET %H=$EXTRACT($HOROLOG,1,5)
+4 DO YX^%DTC
+5 NEW PSUD
SET PSUD=Y
+6 ;
+7 SET Y=PSUSDT
+8 DO DD^%DT
+9 NEW PSUS
SET PSUS=Y
+10 ;
+11 SET Y=PSUEDT
+12 DO DD^%DT
+13 NEW PSUE
SET PSUE=Y
+14 ;
+15 DO IVUDSUM
+16 QUIT
+17 ;
IVUDSUM ;Summary report header
+1 ;
+2 SET ^XTMP("PSU_"_PSUJOB,"PSUSUMA",1)="PHARMACY INPATIENT (UD & IV) UNIQUE PATIENTS REPORT "_PSUD
+3 ;Separator bar
SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUSUMA",2),"-",80)=""
+4 SET ^XTMP("PSU_"_PSUJOB,"PSUSUMA",3)=" "_PSUS_" through "_PSUE
+5 SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUSUMA",4),"=",80)=""
+6 SET ^XTMP("PSU_"_PSUJOB,"PSUSUMA",5)=" UNIQUE"
+7 SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUSUMA",6),"-",70)=""
+8 QUIT
+9 ;
UNIQUE ;Find Total unique patient number across all divisions
+1 ;
+2 NEW PSUSIT
+3 SET PSUSIT=PSUSNDR
+4 ;
+5 NEW PSUIPSUM,PSUOPSUM
+6 IF '$DATA(^XTMP("PSU_"_PSUJOB,"PSUIVIN"))
SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUIVIN"),U,1)=0
+7 IF '$DATA(^XTMP("PSU_"_PSUJOB,"PSUUDIN"))
SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUUDIN"),U,1)=0
+8 IF '$DATA(^XTMP("PSU_"_PSUJOB,"PSUIVOUT"))
SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUIVOUT"),U,1)=0
+9 ;
+10 ;Create IP unique global. Screen out duplicates
+11 MERGE ^XTMP("PSU_"_PSUJOB,"PSUIPSUM")=^XTMP("PSU_"_PSUJOB,"PSUUDIN")
+12 MERGE ^XTMP("PSU_"_PSUJOB,"PSUIPSUM")=^XTMP("PSU_"_PSUJOB,"PSUIN")
+13 ;
+14 SET N=1
+15 SET PSUSUM=0
+16 FOR
SET PSUSUM=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUIPSUM",PSUSUM))
if PSUSUM=""
QUIT
Begin DoDot:1
+17 SET PSUIPSUM=N
SET N=N+1
End DoDot:1
+18 ;
+19 SET PSUOPSUM=$PIECE($GET(^XTMP("PSU_"_PSUJOB,"PSUIVOUT")),U,1)
+20 DO TAB
+21 QUIT
+22 ;
TAB ;Calculate tab spacing
+1 ;
+2 NEW PSUTB2,PSUTB3,PSUTB4,PSUTB5
+3 ;
+4 SET PSUTB1=" "
+5 SET PSUTB2="Total Inpatients across all divisions:"
+6 SET PSUTB3=(64-$LENGTH(PSUIPSUM))-$LENGTH(PSUTB2)
+7 FOR S2=1:1:(PSUTB3-1)
SET PSUTB(S2)=" "
Begin DoDot:1
+8 SET PSUTB1=PSUTB1_PSUTB(S2)
End DoDot:1
+9 ;
+10 SET PSUTB6=" "
+11 SET PSUTB4="Total Outpatients across all divisions:"
+12 SET PSUTB5=(64-$LENGTH(PSUOPSUM))-$LENGTH(PSUTB4)
+13 FOR S3=1:1:(PSUTB5-1)
SET PSUTB(S3)=" "
Begin DoDot:1
+14 SET PSUTB6=PSUTB6_PSUTB(S3)
End DoDot:1
+15 DO TOT
+16 QUIT
+17 ;
TOT ;Set total number of unique in-patients and out-patients into
+1 ;summary message
+2 ;
+3 SET ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=PSUTB2_PSUTB1_(PSUIPSUM)
SET I=I+1
+4 SET ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=PSUTB4_PSUTB6_(PSUOPSUM)
SET I=I+1
+5 SET $PIECE(^XTMP("PSU_"_PSUJOB,"PSUSUMA",I),"-",70)=""
SET I=I+1
+6 QUIT
+7 ;
DIV ;Set all divisions from both IV and UD extracts into one global
+1 ;
+2 ;IP division name/SSN
MERGE ^XTMP("PSU_"_PSUJOB,"PSUFIN")=^XTMP("PSU_"_PSUJOB,"PSUDIV1")
+3 ;UD division name/SSN
MERGE ^XTMP("PSU_"_PSUJOB,"PSUFIN")=^XTMP("PSU_"_PSUJOB,"PSUDIVUD")
+4 QUIT
+5 ;Counter for new global
SET E=1
+6 SET PSUZ=0
+7 FOR
SET PSUZ=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUIVINDIV",PSUZ))
if PSUZ=""
QUIT
Begin DoDot:1
+8 ;IV
SET ^XTMP("PSU_"_PSUJOB,"PSUNEW",PSUZ,E)=$PIECE($GET(^XTMP("PSU_"_PSUJOB,"PSUIVINDIV",PSUZ)),U,1)
+9 SET E=E+1
End DoDot:1
+10 ;
+11 SET PSUZ1=0
+12 FOR
SET PSUZ1=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUUDDIV",PSUZ1))
if PSUZ1=""
QUIT
Begin DoDot:1
+13 SET ^XTMP("PSU_"_PSUJOB,"PSUNEW",PSUZ1,E)=$PIECE($GET(^XTMP("PSU_"_PSUJOB,"PSUUDDIV",PSUZ1)),U,1)
+14 SET E=E+1
End DoDot:1
+15 QUIT
+16 ;
+17 ;
TOTAL ;Calculate sum of all divisions and set individual division lines
+1 ;into summary message
+2 ;
+3 SET T=1
+4 SET PSUDNAM=0
+5 FOR
SET PSUDNAM=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUFIN",PSUDNAM))
if PSUDNAM=""
QUIT
Begin DoDot:1
+6 SET PSUNUM1=0
+7 FOR
SET PSUNUM1=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUFIN",PSUDNAM,PSUNUM1))
if PSUNUM1=""
QUIT
Begin DoDot:2
+8 ;Set total count
SET ^XTMP("PSU_"_PSUJOB,"PSUTOTAL")=T
SET T=T+1
+9 IF $DATA(^XTMP("PSU_"_PSUJOB,"PSUTOT",PSUDNAM))
Begin DoDot:3
+10 SET C=C+1
+11 SET ^XTMP("PSU_"_PSUJOB,"PSUTOT",PSUDNAM)=C
End DoDot:3
+12 IF '$DATA(^XTMP("PSU_"_PSUJOB,"PSUTOT",PSUDNAM))
Begin DoDot:3
+13 SET C=1
+14 SET ^XTMP("PSU_"_PSUJOB,"PSUTOT",PSUDNAM)=C
End DoDot:3
End DoDot:2
End DoDot:1
+15 ;
+16 SET PSUDNAM1=0
+17 NEW PSUSNUM
+18 FOR
SET PSUDNAM1=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUTOT",PSUDNAM1))
if PSUDNAM1=""
QUIT
Begin DoDot:1
+19 SET PSUNUM=$PIECE($GET(^XTMP("PSU_"_PSUJOB,"PSUTOT",PSUDNAM1)),U,1)
+20 DO TAB1
+21 SET ^XTMP("PSU_"_PSUJOB,"PSUSUMA",I)=" "_PSUDNAM1_" Division:"_PSUTB6_PSUNUM
+22 SET I=I+1
End DoDot:1
+23 ;
+24 QUIT
+25 ;
TAB1 ;Calculate tab spacing
+1 ;
+2 SET PSUTB6=" "
+3 SET PSUTB7=(59-$LENGTH(PSUNUM))-$LENGTH(PSUDNAM1)-10
+4 FOR S2=1:1:(PSUTB7-1)
SET PSUTB(S2)=" "
Begin DoDot:1
+5 ;Tab position
SET PSUTB6=PSUTB6_PSUTB(S2)
End DoDot:1
+6 QUIT
+7 ;
NODATA ;Summary report line to be sent if there is no data
+1 ;
+2 SET ^XTMP("PSU_"_PSUJOB,"PSUSUMA",1)="PHARMACY INPATIENT (UD & IV) UNIQUE PATIENTS REPORT"
+3 SET ^XTMP("PSU_"_PSUJOB,"PSUSUMA",2)=" "
+4 SET ^XTMP("PSU_"_PSUJOB,"PSUSUMA",3)="No data to report"
+5 DO PDSUM^PSUDEM5
+6 QUIT
