PSUPR0 ;BIR/PDW - PROCUREMENT EXTRACT ENTRY ROUTINE ;25 AUG 1998
;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
;
;DBIA's
; Reference to file 4.3 supported by DBIA 10091
; Reference to file 4 supported by DBIA 10090
;
EN ;EP from PSUCP
;
; pull variables from ^XTMP
; PSUJOB must exist and must be the job number used to store the data desired for this session.
I '$D(PSUJOB) S PSUJOB=$J
S PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,ZTIO,PSUSNDR,PSUOPTS"
F I=1:1:$L(PSUVARS,",") S @$P(PSUVARS,",",I)=$P(^XTMP("PSU_"_PSUJOB,1),U,I)
PULLQ ;Q
S PSUPRJOB=PSUJOB
S PSUPRSUB="PSUPR_"_PSUPRJOB
; Setup ^XTMP
S X1=DT,X2=6 D C^%DTC
K ^XTMP(PSUPRSUB)
S ^XTMP(PSUPRSUB,0)=X_U_DT_"^ PBM Extract - Procurement Module "
;
; Store Important variables
K X
S X="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUSNDR,PSUPRSUB,PSUJOB,PSURTN,PSUOPTN"
F I=1:1 S Y=$P(X,",",I) Q:Y="" I $D(@Y) S X(Y)=@Y
M ^XTMP(PSUPRSUB,"SAVE")=X
K X
; Process the Procurement Files
; Code for CoreFLS * NOTE: This will be commented out as of 7/1/04
;until such time as CoreFLS code is released.
;S X="PSAFLS" X ^%ZOSF("TEST")
;I $T D
;.S PSUPRSUB="PSUPR_"_$J
;.S PSUFLSFG="" ;FLAG TO SIGNAL COREFLS IN EFFECT
;.D EN^PSUPR2
;.D EN^PSUPR3
;.K PSUFLSFG
;I '$T D ;CoreFLS code. Commented out. When CoreFLS code is
;released put the next 3 lines inside a dot structure.
D EN^PSUPR1 ; file 442
D EN^PSUPR2 ; file 58.811
D EN^PSUPR3 ; file 58.81
K PSUMSG
D EN^PSUPR4(.PSUMSG) ; detailed mail message to Hines
D EN^PSUPR5 ;Summary Mail Routines
;
; return counters to master routine
S PSUSUB="PSU_"_PSUJOB
I $D(^XTMP(PSUSUB)),PSUDUZ,PSUPBMG M ^XTMP(PSUSUB,"CONFIRM")=PSUMSG
;D EN^PSUPR5 ; Summary Mail Routines
Q
PRINT ;EP Tasking Entry Point for PRINT REPORT
D EN^PSUPR6
Q
EXIT ;EP Tasking Entry Point for Cleaning out XTMP and Variables
; Restore Important Variables
K X
M X=^XTMP(PSUPRSUB,"SAVE")
K ^XTMP(PSUPRSUB)
D VARKILL^PSUTL
; Restore Important Variables CONTINUED
S Y="" F S Y=$O(X(Y)) Q:Y="" S @Y=X(Y)
K X
Q
;
CLEAR ;EP clear ^XTMP of PSUPR nodes
S X="PSUPR"
F S X=$O(^XTMP(X)) Q:X="" Q:$E(X,1,5)'="PSUPR" W !,X K ^XTMP(X)
Q
MANUAL ;EP Manual entry point for Running Procurement Module to
; exercise detailed message, summary messages, & Reports
; Some startup code borrowed from PSUCP for dates
W !,"Mail messages are sent to the user only at this time",!
S PSUMON=$E(DT,1,5),(PSUSMRY,PSUMASF,PSUPBMG)=1,PSUDUZ=DUZ
S X=$P($G(^XMB(1,1,"XUS")),U,17),PSUSNDR=+$P(^DIC(4,X,99),U)
K %DT
S %DT="AEX",%DT(0)="-NOW",%DT("A")="STARTING Procurement Extract Date or ""^"" to quit : " D ^%DT
I X["^" Q
I 'Y Q
S PSUSDT=+Y
K %DT W !
S %DT="AEX",%DT(0)=PSUSDT,%DT("A")="ENDING Procurement Extract Date or ""^"" to restart: " D ^%DT
I X["^" G MANUAL
I 'Y G MANUAL
S PSUEDT=+Y
W !
S Y=PSUSDT D DD^%DT W !,"Starting Procurement Date",?30,Y
S Y=PSUEDT D DD^%DT W !,"Ending Procurement Date:",?30,Y
K DIR W !
S DIR(0)="Y",DIR("A")="Correct ? ",DIR("B")="YES" D ^DIR
I 'Y G MANUAL
K DIR W !
W !,"You can not queue to your terminal",!
W !,"You can queue to a host file",!
S DIR(0)="Y",DIR("A")="Do yo want reports printed ? ",DIR("B")="YES" D ^DIR
K DIR W !
S PSURP=+Y
S PSURC="COMPUTE^PSUPR0"
I PSURP S PSURP="PRINT^PSUPR0" K PSUIOP
E K PSURP S PSUIOP="" ; MAIL MESSAGES ONLY
S PSURX="EXIT^PSUPR0"
S PSUNS="PSUPR*,PSUSDT,PSUEDT,PSU*"
D EN^PSUDBQUE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUPR0 3575 printed Dec 13, 2024@02:28:17 Page 2
PSUPR0 ;BIR/PDW - PROCUREMENT EXTRACT ENTRY ROUTINE ;25 AUG 1998
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
+2 ;
+3 ;DBIA's
+4 ; Reference to file 4.3 supported by DBIA 10091
+5 ; Reference to file 4 supported by DBIA 10090
+6 ;
EN ;EP from PSUCP
+1 ;
+2 ; pull variables from ^XTMP
+3 ; PSUJOB must exist and must be the job number used to store the data desired for this session.
+4 IF '$DATA(PSUJOB)
SET PSUJOB=$JOB
+5 SET PSUVARS="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,ZTIO,PSUSNDR,PSUOPTS"
+6 FOR I=1:1:$LENGTH(PSUVARS,",")
SET @$PIECE(PSUVARS,",",I)=$PIECE(^XTMP("PSU_"_PSUJOB,1),U,I)
PULLQ ;Q
+1 SET PSUPRJOB=PSUJOB
+2 SET PSUPRSUB="PSUPR_"_PSUPRJOB
+3 ; Setup ^XTMP
+4 SET X1=DT
SET X2=6
DO C^%DTC
+5 KILL ^XTMP(PSUPRSUB)
+6 SET ^XTMP(PSUPRSUB,0)=X_U_DT_"^ PBM Extract - Procurement Module "
+7 ;
+8 ; Store Important variables
+9 KILL X
+10 SET X="PSUSDT,PSUEDT,PSUMON,PSUDUZ,PSUMASF,PSUPBMG,PSUSMRY,PSUSNDR,PSUPRSUB,PSUJOB,PSURTN,PSUOPTN"
+11 FOR I=1:1
SET Y=$PIECE(X,",",I)
if Y=""
QUIT
IF $DATA(@Y)
SET X(Y)=@Y
+12 MERGE ^XTMP(PSUPRSUB,"SAVE")=X
+13 KILL X
+14 ; Process the Procurement Files
+15 ; Code for CoreFLS * NOTE: This will be commented out as of 7/1/04
+16 ;until such time as CoreFLS code is released.
+17 ;S X="PSAFLS" X ^%ZOSF("TEST")
+18 ;I $T D
+19 ;.S PSUPRSUB="PSUPR_"_$J
+20 ;.S PSUFLSFG="" ;FLAG TO SIGNAL COREFLS IN EFFECT
+21 ;.D EN^PSUPR2
+22 ;.D EN^PSUPR3
+23 ;.K PSUFLSFG
+24 ;I '$T D ;CoreFLS code. Commented out. When CoreFLS code is
+25 ;released put the next 3 lines inside a dot structure.
+26 ; file 442
DO EN^PSUPR1
+27 ; file 58.811
DO EN^PSUPR2
+28 ; file 58.81
DO EN^PSUPR3
+29 KILL PSUMSG
+30 ; detailed mail message to Hines
DO EN^PSUPR4(.PSUMSG)
+31 ;Summary Mail Routines
DO EN^PSUPR5
+32 ;
+33 ; return counters to master routine
+34 SET PSUSUB="PSU_"_PSUJOB
+35 IF $DATA(^XTMP(PSUSUB))
IF PSUDUZ
IF PSUPBMG
MERGE ^XTMP(PSUSUB,"CONFIRM")=PSUMSG
+36 ;D EN^PSUPR5 ; Summary Mail Routines
+37 QUIT
PRINT ;EP Tasking Entry Point for PRINT REPORT
+1 DO EN^PSUPR6
+2 QUIT
EXIT ;EP Tasking Entry Point for Cleaning out XTMP and Variables
+1 ; Restore Important Variables
+2 KILL X
+3 MERGE X=^XTMP(PSUPRSUB,"SAVE")
+4 KILL ^XTMP(PSUPRSUB)
+5 DO VARKILL^PSUTL
+6 ; Restore Important Variables CONTINUED
+7 SET Y=""
FOR
SET Y=$ORDER(X(Y))
if Y=""
QUIT
SET @Y=X(Y)
+8 KILL X
+9 QUIT
+10 ;
CLEAR ;EP clear ^XTMP of PSUPR nodes
+1 SET X="PSUPR"
+2 FOR
SET X=$ORDER(^XTMP(X))
if X=""
QUIT
if $EXTRACT(X,1,5)'="PSUPR"
QUIT
WRITE !,X
KILL ^XTMP(X)
+3 QUIT
MANUAL ;EP Manual entry point for Running Procurement Module to
+1 ; exercise detailed message, summary messages, & Reports
+2 ; Some startup code borrowed from PSUCP for dates
+3 WRITE !,"Mail messages are sent to the user only at this time",!
+4 SET PSUMON=$EXTRACT(DT,1,5)
SET (PSUSMRY,PSUMASF,PSUPBMG)=1
SET PSUDUZ=DUZ
+5 SET X=$PIECE($GET(^XMB(1,1,"XUS")),U,17)
SET PSUSNDR=+$PIECE(^DIC(4,X,99),U)
+6 KILL %DT
+7 SET %DT="AEX"
SET %DT(0)="-NOW"
SET %DT("A")="STARTING Procurement Extract Date or ""^"" to quit : "
DO ^%DT
+8 IF X["^"
QUIT
+9 IF 'Y
QUIT
+10 SET PSUSDT=+Y
+11 KILL %DT
WRITE !
+12 SET %DT="AEX"
SET %DT(0)=PSUSDT
SET %DT("A")="ENDING Procurement Extract Date or ""^"" to restart: "
DO ^%DT
+13 IF X["^"
GOTO MANUAL
+14 IF 'Y
GOTO MANUAL
+15 SET PSUEDT=+Y
+16 WRITE !
+17 SET Y=PSUSDT
DO DD^%DT
WRITE !,"Starting Procurement Date",?30,Y
+18 SET Y=PSUEDT
DO DD^%DT
WRITE !,"Ending Procurement Date:",?30,Y
+19 KILL DIR
WRITE !
+20 SET DIR(0)="Y"
SET DIR("A")="Correct ? "
SET DIR("B")="YES"
DO ^DIR
+21 IF 'Y
GOTO MANUAL
+22 KILL DIR
WRITE !
+23 WRITE !,"You can not queue to your terminal",!
+24 WRITE !,"You can queue to a host file",!
+25 SET DIR(0)="Y"
SET DIR("A")="Do yo want reports printed ? "
SET DIR("B")="YES"
DO ^DIR
+26 KILL DIR
WRITE !
+27 SET PSURP=+Y
+28 SET PSURC="COMPUTE^PSUPR0"
+29 IF PSURP
SET PSURP="PRINT^PSUPR0"
KILL PSUIOP
+30 ; MAIL MESSAGES ONLY
IF '$TEST
KILL PSURP
SET PSUIOP=""
+31 SET PSURX="EXIT^PSUPR0"
+32 SET PSUNS="PSUPR*,PSUSDT,PSUEDT,PSU*"
+33 DO EN^PSUDBQUE
+34 QUIT
