PSURT2 ; BIR/RDC - DYNAMIC REPORT OF PATIENT DEMOGRAPHIC DATA; 12 APR 2004
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
;
; THIS PROGRAM IS CALLED TO EXTRACT DATES FROM ^PSUDEM AND
; CALLS ^PSUDEM1 TO EXTRACT PMB PATIENT DEMOGRAPHIC DATA
;
EN ;
D INITZ
D LODXTMP
D MAILIT
K ^XTMP("PSU"_PSUJOB,"REXMT")
Q
;
INITZ ;
S START=PSUSTART,LAST=PSULAST
I $D(PSURMON) S PSURMON=$E(PSURMON,1,5)
I '$D(PSURMON) S PSURMON=PSUSRNG_" through "_PSUERNG
S PSUJOB=$J_"_"_$P($H,",",2)
S PSUMASF=$G(PSUMASF)
S PSUDUZ=$G(PSUDUZ)
S PSUPBMG=$G(PSUPBMG)
N PSURXMT
S PSURXMT=1
;
S X=$$VALI^PSUTL(4.3,1,217)
S PSUSNDR=+$$VAL^PSUTL(4,X,99)
S X=PSUSNDR,DIC=40.8,DIC(0)="X",D="C" D IX^DIC ; ** set facility
S X=+Y S PSUVDIV=$$VAL^PSUTL(40.8,X,.01) ; ** set division
;
Q
;
LODXTMP ;
;
S START=START-1
F S START=$O(^PSUDEM("B",START)) Q:START>LAST!(START="") D
. S I=""
. S I=$O(^PSUDEM("B",START,I))
. S DFN=$P(^PSUDEM(I,0),U,2)
. S ^XTMP("PSU"_PSUJOB,"REXMT",DFN)=""
;
; ** ^XTMP SHOULD NOW HOLD ONE NODE PER PATIENT FOR THIS TIME FRAME **
Q
;
MAILIT ;
S ^XTMP("PSU_"_PSUJOB,"REXMIT")="YES"
S XMCHAN=1
S XMDUZ=DUZ
I $G(PSUMSTR) S PSUXMYH("G.PSU PBM@CMOP-NAT.DOMAIN.EXT")=""
I $G(PSUMME) S PSUXMYH(DUZ)="",PSUXMYH("G.PSU PBM")=""
M XMY=PSUXMYH
; MAILGROUPS ARE SET INTO XMY
S DFN=""
F S (DFN,PSUDMDFN)=$O(^XTMP("PSU"_PSUJOB,"REXMT",DFN)) Q:PSUDMDFN="" D
. D DAT^PSUDEM1
. D DEM1^PSUDEM1
D XMD^PSUDEM1
D CONFIRM
;
Q
CONFIRM ;
I $G(PSUMSTR) S PSUXMYH("G.PSU PBM@CMOP-NAT.DOMAIN.EXT")=""
I $G(PSUMME) S PSUXMYH(DUZ)="",PSUXMYH("G.PSU PBM")=""
M XMY=PSUXMYH
F I=1:1:79 S $E(ZZ,I)="-"
S PSUPKG="Patient Demographics"
S PSUCONF(1)="The chart below shows the package(s) whose dispensing statistics were extracted"
S PSUCONF(2)="by the PBM Pharmacy Statistics Retransmission option."
S PSUCONF(3)=" "
S PSUCONF(4)="PACKAGE"_$J("# Line items",35)_$J("# MailMan msgs",19)
S PSUCONF(5)=ZZ
K ^XTMP(PSUSUB,"XMD")
M ^XTMP(PSUSUB,"XMD")=PSUCONF
S ^XTMP(PSUSUB,"XMD",6)=PSUPKG_$J(PSUMLC,37-$L(PSUPKG))_$J(PSUM,12)
S XMSUB="V. 4.0 PBMRXMT "_PSURMON_" "_PSUSIT_" "_PSUDIVNM
S XMDUZ=DUZ
S XMCHAN=1
S XMTEXT="^XTMP(PSUSUB,""XMD"","
D ^XMD
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSURT2 2263 printed Apr 09, 2024@21:30:55 Page 2
PSURT2 ; BIR/RDC - DYNAMIC REPORT OF PATIENT DEMOGRAPHIC DATA; 12 APR 2004
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ;
+3 ; THIS PROGRAM IS CALLED TO EXTRACT DATES FROM ^PSUDEM AND
+4 ; CALLS ^PSUDEM1 TO EXTRACT PMB PATIENT DEMOGRAPHIC DATA
+5 ;
EN ;
+1 DO INITZ
+2 DO LODXTMP
+3 DO MAILIT
+4 KILL ^XTMP("PSU"_PSUJOB,"REXMT")
+5 QUIT
+6 ;
INITZ ;
+1 SET START=PSUSTART
SET LAST=PSULAST
+2 IF $DATA(PSURMON)
SET PSURMON=$EXTRACT(PSURMON,1,5)
+3 IF '$DATA(PSURMON)
SET PSURMON=PSUSRNG_" through "_PSUERNG
+4 SET PSUJOB=$JOB_"_"_$PIECE($HOROLOG,",",2)
+5 SET PSUMASF=$GET(PSUMASF)
+6 SET PSUDUZ=$GET(PSUDUZ)
+7 SET PSUPBMG=$GET(PSUPBMG)
+8 NEW PSURXMT
+9 SET PSURXMT=1
+10 ;
+11 SET X=$$VALI^PSUTL(4.3,1,217)
+12 SET PSUSNDR=+$$VAL^PSUTL(4,X,99)
+13 ; ** set facility
SET X=PSUSNDR
SET DIC=40.8
SET DIC(0)="X"
SET D="C"
DO IX^DIC
+14 ; ** set division
SET X=+Y
SET PSUVDIV=$$VAL^PSUTL(40.8,X,.01)
+15 ;
+16 QUIT
+17 ;
LODXTMP ;
+1 ;
+2 SET START=START-1
+3 FOR
SET START=$ORDER(^PSUDEM("B",START))
if START>LAST!(START="")
QUIT
Begin DoDot:1
+4 SET I=""
+5 SET I=$ORDER(^PSUDEM("B",START,I))
+6 SET DFN=$PIECE(^PSUDEM(I,0),U,2)
+7 SET ^XTMP("PSU"_PSUJOB,"REXMT",DFN)=""
End DoDot:1
+8 ;
+9 ; ** ^XTMP SHOULD NOW HOLD ONE NODE PER PATIENT FOR THIS TIME FRAME **
+10 QUIT
+11 ;
MAILIT ;
+1 SET ^XTMP("PSU_"_PSUJOB,"REXMIT")="YES"
+2 SET XMCHAN=1
+3 SET XMDUZ=DUZ
+4 IF $GET(PSUMSTR)
SET PSUXMYH("G.PSU PBM@CMOP-NAT.DOMAIN.EXT")=""
+5 IF $GET(PSUMME)
SET PSUXMYH(DUZ)=""
SET PSUXMYH("G.PSU PBM")=""
+6 MERGE XMY=PSUXMYH
+7 ; MAILGROUPS ARE SET INTO XMY
+8 SET DFN=""
+9 FOR
SET (DFN,PSUDMDFN)=$ORDER(^XTMP("PSU"_PSUJOB,"REXMT",DFN))
if PSUDMDFN=""
QUIT
Begin DoDot:1
+10 DO DAT^PSUDEM1
+11 DO DEM1^PSUDEM1
End DoDot:1
+12 DO XMD^PSUDEM1
+13 DO CONFIRM
+14 ;
+15 QUIT
CONFIRM ;
+1 IF $GET(PSUMSTR)
SET PSUXMYH("G.PSU PBM@CMOP-NAT.DOMAIN.EXT")=""
+2 IF $GET(PSUMME)
SET PSUXMYH(DUZ)=""
SET PSUXMYH("G.PSU PBM")=""
+3 MERGE XMY=PSUXMYH
+4 FOR I=1:1:79
SET $EXTRACT(ZZ,I)="-"
+5 SET PSUPKG="Patient Demographics"
+6 SET PSUCONF(1)="The chart below shows the package(s) whose dispensing statistics were extracted"
+7 SET PSUCONF(2)="by the PBM Pharmacy Statistics Retransmission option."
+8 SET PSUCONF(3)=" "
+9 SET PSUCONF(4)="PACKAGE"_$JUSTIFY("# Line items",35)_$JUSTIFY("# MailMan msgs",19)
+10 SET PSUCONF(5)=ZZ
+11 KILL ^XTMP(PSUSUB,"XMD")
+12 MERGE ^XTMP(PSUSUB,"XMD")=PSUCONF
+13 SET ^XTMP(PSUSUB,"XMD",6)=PSUPKG_$JUSTIFY(PSUMLC,37-$LENGTH(PSUPKG))_$JUSTIFY(PSUM,12)
+14 SET XMSUB="V. 4.0 PBMRXMT "_PSURMON_" "_PSUSIT_" "_PSUDIVNM
+15 SET XMDUZ=DUZ
+16 SET XMCHAN=1
+17 SET XMTEXT="^XTMP(PSUSUB,""XMD"","
+18 DO ^XMD
+19 ;
+20 QUIT
