PRCOER1 ;WISC/DJM-EDI REPORTS USING LIST MANAGER ; [8/31/98 2:26pm]
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
REPORTS ; COME HERE TO ENTER THE REPORTS GENERATOR.
;
N DIR,X,Y,LIST,Q1,Q2,PRCA,PRCB,PRCSA,I,PRCPOS,PRCLST,PRCBLST
N POSI,POS,PRCC,%DT,DTOUT,START,END,FIRST,LAST,A
D CLEAR^VALM1
;
R0 S LIST=""
D LF
S DIR("A")="Select PHA, RFQ or All: "
S DIR("?")="^D WRONG^PRCOER1()"
S DIR(0)="FAO^1:30"
D ^DIR K DIR
G R4:$D(DUOUT),R4:$D(DTOUT)
I X="" D G R4:X["^",R0
. D LF
. D PAUSE
. D LF
I X["-" G R2
I X["," G R3
I $L(X)>3 D WRONG(X) D PAUSE G R4:X["^",R0
;
R1 ; IS THIS ONE OF THE CORRECT INPUTS?
S Y=""
D CHECK(X,.Y)
I Y>3,Y<7 D WRONG(X),PAUSE G R0
I Y>0 S LIST=Y_"," G DATE
D WRONG(X)
D PAUSE
G R4:X["^",R0
;
R2 K Q1,Q2
S PRCA=$P(X,"-",1)
S PRCB=$P(X,"-",2)
I PRCA["," D G:LIST["0" P2 G R2B
. S PRCSA=X
. S X=PRCA
. D P3
. S X=PRCSA
. I LIST["0" Q
. S I=1
. F S:$P(LIST,",",I)]"" PRCPOS=$P(LIST,",",I) Q:$P(LIST,",",I)="" S I=I+1
. S Q1=$E(LIST,PRCPOS)
. S PRCLST=LIST
. Q
S Y=""
D CHECK(PRCA,.Y)
I Y>3,Y<7 D WRONG(X),PAUSE G R0
I $G(Q1)="" S PRCLST=Y
S Q1=Y
R2B S PRCBLST=PRCB
I PRCB["," D G:LIST["0" P2 G R2C
. S PRCSA=X
. S X=PRCB
. D P3
. S X=PRCSA
. I LIST["0" Q
. S Q2=$P(LIST,",")
. S PRCBLST=LIST
. Q
D CHECK(PRCB,.Y)
I Y>3,Y<7 D WRONG(X),PAUSE G R0
I $G(Q2)="" S PRCBLST=Y
S Q2=Y
I Q1=0 D WRONG(PRCA) G P2
I Q2=0 D WRONG(PRCB) G P2
;
R2C I $G(PRCLST)[7!($G(PRCBLST)[7) S LIST=7_"," G DATE
S LIST=""
I Q1>Q2 F I=Q2:1:Q1 S LIST=LIST_I_","
I Q2>Q1 F I=Q1:1:Q2 S LIST=LIST_I_","
S:$G(PRCLST)]"" LIST=LIST_PRCLST
S:$G(PRCBLST)]"" LIST=LIST_PRCBLST
F I=1:1 S POSI=$P(LIST,",",I) Q:POSI="" S POS(POSI)=POSI
S LIST=""
F I=1:1:3 S:$G(POS(I))]"" LIST=LIST_POS(I)_","
K POS
G DATE
;
P2 D PAUSE
G R4:X["^",R0
P3 S LIST=""
F I=1:1 S PRCC=$P(X,",",I) Q:PRCC="" D Q:"70"[LIST
. S Y=""
. D CHECK(PRCC,.Y)
. I Y>3,Y<7 D WRONG(X) S LIST=0 Q
. I Y=0 D WRONG(PRCC) S LIST=0 Q
. I Y=7 S LIST=7_"," Q
. S LIST=LIST_Y_","
. Q
Q
;
R3 D P3
I LIST'["0" G DATE
D PAUSE
G R4:X["^",R0
;
R4 S VALMBCK="R"
S VALMBG=1
Q
;
DATE D RT ; prompt user for from and to date range
I $S('$G(PRCOBEG):1,'$G(PRCOSTOP):1,1:0) G RT1
I LIST="" G P2
G ^PRCOER3
;
IT ; SELECT ACCEPTED, REJECTED OR INCOMMING TRANSACTIONS WITH PROBLEMS.
Q
;
RT1 D:$G(X)'="^" PAUSE
G R4:X["^",R0
;
PO ; FIND OUT IF USER WANTS TO DISPLAY 'POA' RECORDS
Q
;
WRONG(X) ; COME HERE IF THE USER'S INPUT IS WRONG.
S A(1)=$S($G(X)]"":X_" ?? "_$C(7),1:"")
S A(2)=" "
S A(3)="Enter a selection, more than one selection separated with a ','"
S A(4)="a range of selections seperated with a '-' or exclude an entry with a '."
S A(5)=" "
D EN^DDIOL(.A)
Q
;
CHECK(X,Y) ; COME HERE TO SEE IF INPUT IS ONE OF THE CORRECT ENTRIES.
;
; RETURN A NUMBER THAT REPRESENTS THE INPUT.
;
; PHA 1
; RFQ 2
; TXT 3
; ACT 4
; PRJ 5
; POA 6
; ALL 7
; WRONG 0
;
; THE RETURNED VALUE OF "0" MEANS THAT THE USER DID NOT ENTER ANY
; CORRECT ENTRY.
;
S X=$S(X["P":"PHA",X["R":"RFQ",X["A":"ALL",1:X)
S Y=$S(X="PHA":1,X="RFQ":2,X="TXT":3,X="ACT":4,X="PRJ":5,X="POA":6,X="ALL":7,1:0)
Q
;
RT ; Ask user from date. Must be less than "NOW".
; returns PRCOBEG
N AA
K PRCOBEG,PRCOSTOP
D LF
D NOW^%DTC
S AA=$E(X,1,3)-1
S Y=AA_$E(X,4,7)
D DD^%DT
S DIR(0)="D^:-NOW:AET"
S DIR("A")="Enter the DATE/TIME CREATED starting date"
S DIR("B")=Y
D ^DIR K DIR
Q:$D(DIRUT)
S PRCOBEG=$S(Y[".":Y,1:Y_".000001")
;
RT0 ; Ask user end date. Date must be > BEG date and less
; than "NOW".
; returns PRCOSTOP
Q:'$G(PRCOBEG)
S DIR(0)="D^"_PRCOBEG_":-NOW:AET"
S DIR("A")="Enter the DATE/TIME CREATED ending date"
S DIR("B")="NOW"
D LF
D ^DIR K DIR
Q:$D(DIRUT)
S PRCOSTOP=Y
I PRCOSTOP'["." D ;if no time entered by user
. ;
. ; set end date to "NOW" if end date is "TODAY".
. ;
. I PRCOSTOP=$G(DT) S PRCOSTOP=$$NOW^XLFDT Q
. S PRCOSTOP=PRCOSTOP_".235959" ;attach time for end of day
;
K DUOUT,DIRUT,DTOUT
Q
;
PAUSE ; Come here to allow user to read screen before continuing.
N DIR,DIRUT,DUOUT,DTOUT
S DIR(0)="E"
D ^DIR
Q
LF ; Line feed
D EN^DDIOL("","","!")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCOER1 4481 printed Oct 16, 2024@18:12:39 Page 2
PRCOER1 ;WISC/DJM-EDI REPORTS USING LIST MANAGER ; [8/31/98 2:26pm]
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
REPORTS ; COME HERE TO ENTER THE REPORTS GENERATOR.
+1 ;
+2 NEW DIR,X,Y,LIST,Q1,Q2,PRCA,PRCB,PRCSA,I,PRCPOS,PRCLST,PRCBLST
+3 NEW POSI,POS,PRCC,%DT,DTOUT,START,END,FIRST,LAST,A
+4 DO CLEAR^VALM1
+5 ;
R0 SET LIST=""
+1 DO LF
+2 SET DIR("A")="Select PHA, RFQ or All: "
+3 SET DIR("?")="^D WRONG^PRCOER1()"
+4 SET DIR(0)="FAO^1:30"
+5 DO ^DIR
KILL DIR
+6 if $DATA(DUOUT)
GOTO R4
if $DATA(DTOUT)
GOTO R4
+7 IF X=""
Begin DoDot:1
+8 DO LF
+9 DO PAUSE
+10 DO LF
End DoDot:1
if X["^"
GOTO R4
GOTO R0
+11 IF X["-"
GOTO R2
+12 IF X[","
GOTO R3
+13 IF $LENGTH(X)>3
DO WRONG(X)
DO PAUSE
if X["^"
GOTO R4
GOTO R0
+14 ;
R1 ; IS THIS ONE OF THE CORRECT INPUTS?
+1 SET Y=""
+2 DO CHECK(X,.Y)
+3 IF Y>3
IF Y<7
DO WRONG(X)
DO PAUSE
GOTO R0
+4 IF Y>0
SET LIST=Y_","
GOTO DATE
+5 DO WRONG(X)
+6 DO PAUSE
+7 if X["^"
GOTO R4
GOTO R0
+8 ;
R2 KILL Q1,Q2
+1 SET PRCA=$PIECE(X,"-",1)
+2 SET PRCB=$PIECE(X,"-",2)
+3 IF PRCA[","
Begin DoDot:1
+4 SET PRCSA=X
+5 SET X=PRCA
+6 DO P3
+7 SET X=PRCSA
+8 IF LIST["0"
QUIT
+9 SET I=1
+10 FOR
if $PIECE(LIST,",",I)]""
SET PRCPOS=$PIECE(LIST,",",I)
if $PIECE(LIST,",",I)=""
QUIT
SET I=I+1
+11 SET Q1=$EXTRACT(LIST,PRCPOS)
+12 SET PRCLST=LIST
+13 QUIT
End DoDot:1
if LIST["0"
GOTO P2
GOTO R2B
+14 SET Y=""
+15 DO CHECK(PRCA,.Y)
+16 IF Y>3
IF Y<7
DO WRONG(X)
DO PAUSE
GOTO R0
+17 IF $GET(Q1)=""
SET PRCLST=Y
+18 SET Q1=Y
R2B SET PRCBLST=PRCB
+1 IF PRCB[","
Begin DoDot:1
+2 SET PRCSA=X
+3 SET X=PRCB
+4 DO P3
+5 SET X=PRCSA
+6 IF LIST["0"
QUIT
+7 SET Q2=$PIECE(LIST,",")
+8 SET PRCBLST=LIST
+9 QUIT
End DoDot:1
if LIST["0"
GOTO P2
GOTO R2C
+10 DO CHECK(PRCB,.Y)
+11 IF Y>3
IF Y<7
DO WRONG(X)
DO PAUSE
GOTO R0
+12 IF $GET(Q2)=""
SET PRCBLST=Y
+13 SET Q2=Y
+14 IF Q1=0
DO WRONG(PRCA)
GOTO P2
+15 IF Q2=0
DO WRONG(PRCB)
GOTO P2
+16 ;
R2C IF $GET(PRCLST)[7!($GET(PRCBLST)[7)
SET LIST=7_","
GOTO DATE
+1 SET LIST=""
+2 IF Q1>Q2
FOR I=Q2:1:Q1
SET LIST=LIST_I_","
+3 IF Q2>Q1
FOR I=Q1:1:Q2
SET LIST=LIST_I_","
+4 if $GET(PRCLST)]""
SET LIST=LIST_PRCLST
+5 if $GET(PRCBLST)]""
SET LIST=LIST_PRCBLST
+6 FOR I=1:1
SET POSI=$PIECE(LIST,",",I)
if POSI=""
QUIT
SET POS(POSI)=POSI
+7 SET LIST=""
+8 FOR I=1:1:3
if $GET(POS(I))]""
SET LIST=LIST_POS(I)_","
+9 KILL POS
+10 GOTO DATE
+11 ;
P2 DO PAUSE
+1 if X["^"
GOTO R4
GOTO R0
P3 SET LIST=""
+1 FOR I=1:1
SET PRCC=$PIECE(X,",",I)
if PRCC=""
QUIT
Begin DoDot:1
+2 SET Y=""
+3 DO CHECK(PRCC,.Y)
+4 IF Y>3
IF Y<7
DO WRONG(X)
SET LIST=0
QUIT
+5 IF Y=0
DO WRONG(PRCC)
SET LIST=0
QUIT
+6 IF Y=7
SET LIST=7_","
QUIT
+7 SET LIST=LIST_Y_","
+8 QUIT
End DoDot:1
if "70"[LIST
QUIT
+9 QUIT
+10 ;
R3 DO P3
+1 IF LIST'["0"
GOTO DATE
+2 DO PAUSE
+3 if X["^"
GOTO R4
GOTO R0
+4 ;
R4 SET VALMBCK="R"
+1 SET VALMBG=1
+2 QUIT
+3 ;
DATE ; prompt user for from and to date range
DO RT
+1 IF $SELECT('$GET(PRCOBEG):1,'$GET(PRCOSTOP):1,1:0)
GOTO RT1
+2 IF LIST=""
GOTO P2
+3 GOTO ^PRCOER3
+4 ;
IT ; SELECT ACCEPTED, REJECTED OR INCOMMING TRANSACTIONS WITH PROBLEMS.
+1 QUIT
+2 ;
RT1 if $GET(X)'="^"
DO PAUSE
+1 if X["^"
GOTO R4
GOTO R0
+2 ;
PO ; FIND OUT IF USER WANTS TO DISPLAY 'POA' RECORDS
+1 QUIT
+2 ;
WRONG(X) ; COME HERE IF THE USER'S INPUT IS WRONG.
+1 SET A(1)=$SELECT($GET(X)]"":X_" ?? "_$CHAR(7),1:"")
+2 SET A(2)=" "
+3 SET A(3)="Enter a selection, more than one selection separated with a ','"
+4 SET A(4)="a range of selections seperated with a '-' or exclude an entry with a '."
+5 SET A(5)=" "
+6 DO EN^DDIOL(.A)
+7 QUIT
+8 ;
CHECK(X,Y) ; COME HERE TO SEE IF INPUT IS ONE OF THE CORRECT ENTRIES.
+1 ;
+2 ; RETURN A NUMBER THAT REPRESENTS THE INPUT.
+3 ;
+4 ; PHA 1
+5 ; RFQ 2
+6 ; TXT 3
+7 ; ACT 4
+8 ; PRJ 5
+9 ; POA 6
+10 ; ALL 7
+11 ; WRONG 0
+12 ;
+13 ; THE RETURNED VALUE OF "0" MEANS THAT THE USER DID NOT ENTER ANY
+14 ; CORRECT ENTRY.
+15 ;
+16 SET X=$SELECT(X["P":"PHA",X["R":"RFQ",X["A":"ALL",1:X)
+17 SET Y=$SELECT(X="PHA":1,X="RFQ":2,X="TXT":3,X="ACT":4,X="PRJ":5,X="POA":6,X="ALL":7,1:0)
+18 QUIT
+19 ;
RT ; Ask user from date. Must be less than "NOW".
+1 ; returns PRCOBEG
+2 NEW AA
+3 KILL PRCOBEG,PRCOSTOP
+4 DO LF
+5 DO NOW^%DTC
+6 SET AA=$EXTRACT(X,1,3)-1
+7 SET Y=AA_$EXTRACT(X,4,7)
+8 DO DD^%DT
+9 SET DIR(0)="D^:-NOW:AET"
+10 SET DIR("A")="Enter the DATE/TIME CREATED starting date"
+11 SET DIR("B")=Y
+12 DO ^DIR
KILL DIR
+13 if $DATA(DIRUT)
QUIT
+14 SET PRCOBEG=$SELECT(Y[".":Y,1:Y_".000001")
+15 ;
RT0 ; Ask user end date. Date must be > BEG date and less
+1 ; than "NOW".
+2 ; returns PRCOSTOP
+3 if '$GET(PRCOBEG)
QUIT
+4 SET DIR(0)="D^"_PRCOBEG_":-NOW:AET"
+5 SET DIR("A")="Enter the DATE/TIME CREATED ending date"
+6 SET DIR("B")="NOW"
+7 DO LF
+8 DO ^DIR
KILL DIR
+9 if $DATA(DIRUT)
QUIT
+10 SET PRCOSTOP=Y
+11 ;if no time entered by user
IF PRCOSTOP'["."
Begin DoDot:1
+12 ;
+13 ; set end date to "NOW" if end date is "TODAY".
+14 ;
+15 IF PRCOSTOP=$GET(DT)
SET PRCOSTOP=$$NOW^XLFDT
QUIT
+16 ;attach time for end of day
SET PRCOSTOP=PRCOSTOP_".235959"
End DoDot:1
+17 ;
+18 KILL DUOUT,DIRUT,DTOUT
+19 QUIT
+20 ;
PAUSE ; Come here to allow user to read screen before continuing.
+1 NEW DIR,DIRUT,DUOUT,DTOUT
+2 SET DIR(0)="E"
+3 DO ^DIR
+4 QUIT
LF ; Line feed
+1 DO EN^DDIOL("","","!")
+2 QUIT
