- 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 Jan 18, 2025@03:28:59 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