- 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 Mar 13, 2025@21:32:54 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
