PRCSDIC ;WISC/CTB/KMB-INTERCEPT FOR DIC LOOKUP INTO FILE 410 ;3-19-91/17:13
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;INTERCEPT ROUTINE LOOKUP INTO FILE 410
N I,D,X1,X2 S:$D(X3) D=X3
K DUOUT,DTOUT S U="^" I $D(D),D'="H",D=+D K D
S Y=-1 S:'$D(DIC) DIC=410 S:'$D(DIC(0)) DIC(0)="EMQZ"
F I=1:1 Q:DIC(0)'["A" S DIC(0)=$P(DIC(0),"A")_$P(DIC(0),"A",2,99) ;STRIP "A" FROM DIC(0) STRING IF NECESSARY
F I=1:1 Q:DIC(0)'["M" S DIC(0)=$P(DIC(0),"M")_$P(DIC(0),"M",2,99) ;STRIP "M" FROM DIC(0) STRING IF NECESSARY
W !,$S($D(DIC("A")):DIC("A"),1:"Select CONTROL POINT ACTIVITY TRANSACTION NUMBER: ") R X:DTIME I '$T!(X="")!($E(X)="^") S Y=-1 Q
I X=" " D ^DIC Q:+Y>0 G ER
CHECK ;
I $D(X3),X?1."?" W !,"Please enter number using an alpha character",!,"and 2-16 alphanumerics,as in 'A1234B'",!! G V
I $D(X3),X'?1."?",X'?1U.UNP W !!,"Incorrect format - please re-enter number",!! G V
I $E(X)="." S X="The first character may not be a '.'.*" D MSG^PRCFQ G ER
I "V.v.W.w.P.p.T.t.C.c."[$E(X,1,2) S X1=$P(X,"."),X=$P(X,".",2,99) I X'?1."?" S:$A(X1)>90 X1=$C($A(X1)-32) S X1=$F("VWPTC",X1)-1 S:$D(D)[0 D="" S:X1>0 X2="E^J^D^H^AN",D=$S(D="":$P(X2,"^",X1),1:D_"^"_$P(X2,U,X1)) K X1,X2
I $D(PRCSID),PRCSID=1,X?4N S D="F1",DIC(0)=DIC(0)_"M" D MIX^DIC1 Q:+Y>0 G ER
I X'?1."?",$D(D)'[0,D]"",D'["^" D IX^DIC Q:+Y>0 G ER
I X'?1."?",$D(D)'[0,D]"",D["^" S:DIC(0)'["M" DIC(0)=DIC(0)_"M" D MIX^DIC1 Q:+Y>0 G ER
I $E(X,1,8)?3N1"-"2N1"-"1N S DIC(0)=DIC(0)_"M" D ^DIC Q:+Y>0 G ER
I X?3N1"-"2N D STA G ER
I X?2N1"-"4N S D="B3" D IX^DIC Q:+Y>0 G ER
I X?4N S D="B2^AN^F1",DIC(0)=DIC(0)_"M" D MIX^DIC1 Q:+Y>0 G ER
I $D(PRC("SITE")),X=PRC("SITE") D STA G ER
I $D(PRC("SITE")),X=(PRC("SITE")_"-") D STA G ER
I $L(X)=1,X'="?" W !! S X="Single Character Lookups have been prohibited." D MSG^PRCFQ R X:3 S X="?"
I X'?1."?" S:DIC(0)'["M" DIC(0)=DIC(0)_"M" S D="AN^D^E^H^J^I^C" D MIX^DIC1 Q:Y>0 G ER
I '$D(X3),$D(PRC("SITE")),$D(PRC("FY")),$D(PRC("QTR")),$D(PRC("CP")) S X1=X,X2="(STA # - FY - QTR - FCP)",X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," "),D="B" D X,IX^DIC Q:Y>0 G ER
I '$D(X3),$D(PRC("SITE")),$D(PRC("FY")),$D(PRC("QTR")) S X1=X,X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR"),D="B",X2="(STA # - FY - QTR)" D X,IX^DIC Q:Y>0 G ER
I '$D(X3),$D(PRC("CP")) S X1=X,X=$P(PRC("CP")," "),D="AN",X2="(CONTROL POINT)" D X,IX^DIC Q:Y>0 G ER
I X?1."?" D QM
ER I $D(DTOUT),DTOUT,$S('$D(X1):1,X1'?1."?":1,1:0) G V
G:X="^" V
I $D(X3) W !!,"Please enter a number using an alpha character",!,"and 2-16 alphanumerics, as in 'ADP1'.",!
E F I=1:1 W ! Q:$P($T(TEXT+I),";",3)="XXX" W $P($T(TEXT+I),";",3)
G V
QM W !!,"Attempting lookup in transaction file.",$C(7) Q
X I $D(X1),X1?1."?" D QM
W !!,"Attempting lookup using "_X_" "_$S($D(X2):X2,1:""),!
Q
STA W ! S X="Station number or SN-FY alone are no longer allowed for lookup.*" D MSG^PRCFQ R X:3 S X="?",X1="NO?" G ER
TEXT ;;
;;
;;Please answer with any of the following:
;;
;; TRANSACTION NUMBER - (Station-FY-QTR-Control Point-Sequence Number)
;; or a fragment of the number. NOTE:
;; STATION NUMBER or SN-FY alone are not enough
;;PURCHASE ORDER NUMBER - e.g. A01234
;; VENDOR NAME
;; TEMPORARY NUMBER - E.G. ADP1
;; SEQUENCE NUMBER - Last 4 numbers of Transaction Number
;; WORK ORDER NUMBER
;; SORT GROUP
;;
;;To go directly to the Vendor, Control Point, Purchase Order, Work Order
;;or Temporary Transaction cross reference, you may enter:
;;'V.', 'C.', 'P.', 'W.' or 'T.' followed by the lookup value. - E.G. V.IBM
;;XXX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSDIC 3704 printed Dec 13, 2024@02:17:26 Page 2
PRCSDIC ;WISC/CTB/KMB-INTERCEPT FOR DIC LOOKUP INTO FILE 410 ;3-19-91/17:13
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;INTERCEPT ROUTINE LOOKUP INTO FILE 410
+3 NEW I,D,X1,X2
if $DATA(X3)
SET D=X3
+4 KILL DUOUT,DTOUT
SET U="^"
IF $DATA(D)
IF D'="H"
IF D=+D
KILL D
+5 SET Y=-1
if '$DATA(DIC)
SET DIC=410
if '$DATA(DIC(0))
SET DIC(0)="EMQZ"
+6 ;STRIP "A" FROM DIC(0) STRING IF NECESSARY
FOR I=1:1
if DIC(0)'["A"
QUIT
SET DIC(0)=$PIECE(DIC(0),"A")_$PIECE(DIC(0),"A",2,99)
+7 ;STRIP "M" FROM DIC(0) STRING IF NECESSARY
FOR I=1:1
if DIC(0)'["M"
QUIT
SET DIC(0)=$PIECE(DIC(0),"M")_$PIECE(DIC(0),"M",2,99)
+8 WRITE !,$SELECT($DATA(DIC("A")):DIC("A"),1:"Select CONTROL POINT ACTIVITY TRANSACTION NUMBER: ")
READ X:DTIME
IF '$TEST!(X="")!($EXTRACT(X)="^")
SET Y=-1
QUIT
+9 IF X=" "
DO ^DIC
if +Y>0
QUIT
GOTO ER
CHECK ;
+1 IF $DATA(X3)
IF X?1."?"
WRITE !,"Please enter number using an alpha character",!,"and 2-16 alphanumerics,as in 'A1234B'",!!
GOTO V
+2 IF $DATA(X3)
IF X'?1."?"
IF X'?1U.UNP
WRITE !!,"Incorrect format - please re-enter number",!!
GOTO V
+3 IF $EXTRACT(X)="."
SET X="The first character may not be a '.'.*"
DO MSG^PRCFQ
GOTO ER
+4 IF "V.v.W.w.P.p.T.t.C.c."[$EXTRACT(X,1,2)
SET X1=$PIECE(X,".")
SET X=$PIECE(X,".",2,99)
IF X'?1."?"
if $ASCII(X1)>90
SET X1=$CHAR($ASCII(X1)-32)
SET X1=$FIND("VWPTC",X1)-1
if $DATA(D)[0
SET D=""
if X1>0
SET X2="E^J^D^H^AN"
SET D=$SELECT(D="":$PIECE(X2,"^",X1),1:D_"^"_$PIECE(X2,U,X1))
KILL X1,X2
+5 IF $DATA(PRCSID)
IF PRCSID=1
IF X?4N
SET D="F1"
SET DIC(0)=DIC(0)_"M"
DO MIX^DIC1
if +Y>0
QUIT
GOTO ER
+6 IF X'?1."?"
IF $DATA(D)'[0
IF D]""
IF D'["^"
DO IX^DIC
if +Y>0
QUIT
GOTO ER
+7 IF X'?1."?"
IF $DATA(D)'[0
IF D]""
IF D["^"
if DIC(0)'["M"
SET DIC(0)=DIC(0)_"M"
DO MIX^DIC1
if +Y>0
QUIT
GOTO ER
+8 IF $EXTRACT(X,1,8)?3N1"-"2N1"-"1N
SET DIC(0)=DIC(0)_"M"
DO ^DIC
if +Y>0
QUIT
GOTO ER
+9 IF X?3N1"-"2N
DO STA
GOTO ER
+10 IF X?2N1"-"4N
SET D="B3"
DO IX^DIC
if +Y>0
QUIT
GOTO ER
+11 IF X?4N
SET D="B2^AN^F1"
SET DIC(0)=DIC(0)_"M"
DO MIX^DIC1
if +Y>0
QUIT
GOTO ER
+12 IF $DATA(PRC("SITE"))
IF X=PRC("SITE")
DO STA
GOTO ER
+13 IF $DATA(PRC("SITE"))
IF X=(PRC("SITE")_"-")
DO STA
GOTO ER
+14 IF $LENGTH(X)=1
IF X'="?"
WRITE !!
SET X="Single Character Lookups have been prohibited."
DO MSG^PRCFQ
READ X:3
SET X="?"
+15 IF X'?1."?"
if DIC(0)'["M"
SET DIC(0)=DIC(0)_"M"
SET D="AN^D^E^H^J^I^C"
DO MIX^DIC1
if Y>0
QUIT
GOTO ER
+16 IF '$DATA(X3)
IF $DATA(PRC("SITE"))
IF $DATA(PRC("FY"))
IF $DATA(PRC("QTR"))
IF $DATA(PRC("CP"))
SET X1=X
SET X2="(STA # - FY - QTR - FCP)"
SET X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
SET D="B"
DO X
DO IX^DIC
if Y>0
QUIT
GOTO ER
+17 IF '$DATA(X3)
IF $DATA(PRC("SITE"))
IF $DATA(PRC("FY"))
IF $DATA(PRC("QTR"))
SET X1=X
SET X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")
SET D="B"
SET X2="(STA # - FY - QTR)"
DO X
DO IX^DIC
if Y>0
QUIT
GOTO ER
+18 IF '$DATA(X3)
IF $DATA(PRC("CP"))
SET X1=X
SET X=$PIECE(PRC("CP")," ")
SET D="AN"
SET X2="(CONTROL POINT)"
DO X
DO IX^DIC
if Y>0
QUIT
GOTO ER
+19 IF X?1."?"
DO QM
ER IF $DATA(DTOUT)
IF DTOUT
IF $SELECT('$DATA(X1):1,X1'?1."?":1,1:0)
GOTO V
+1 if X="^"
GOTO V
+2 IF $DATA(X3)
WRITE !!,"Please enter a number using an alpha character",!,"and 2-16 alphanumerics, as in 'ADP1'.",!
+3 IF '$TEST
FOR I=1:1
WRITE !
if $PIECE($TEXT(TEXT+I),";",3)="XXX"
QUIT
WRITE $PIECE($TEXT(TEXT+I),";",3)
+4 GOTO V
QM WRITE !!,"Attempting lookup in transaction file.",$CHAR(7)
QUIT
X IF $DATA(X1)
IF X1?1."?"
DO QM
+1 WRITE !!,"Attempting lookup using "_X_" "_$SELECT($DATA(X2):X2,1:""),!
+2 QUIT
STA WRITE !
SET X="Station number or SN-FY alone are no longer allowed for lookup.*"
DO MSG^PRCFQ
READ X:3
SET X="?"
SET X1="NO?"
GOTO ER
TEXT ;;
+1 ;;
+2 ;;Please answer with any of the following:
+3 ;;
+4 ;; TRANSACTION NUMBER - (Station-FY-QTR-Control Point-Sequence Number)
+5 ;; or a fragment of the number. NOTE:
+6 ;; STATION NUMBER or SN-FY alone are not enough
+7 ;;PURCHASE ORDER NUMBER - e.g. A01234
+8 ;; VENDOR NAME
+9 ;; TEMPORARY NUMBER - E.G. ADP1
+10 ;; SEQUENCE NUMBER - Last 4 numbers of Transaction Number
+11 ;; WORK ORDER NUMBER
+12 ;; SORT GROUP
+13 ;;
+14 ;;To go directly to the Vendor, Control Point, Purchase Order, Work Order
+15 ;;or Temporary Transaction cross reference, you may enter:
+16 ;;'V.', 'C.', 'P.', 'W.' or 'T.' followed by the lookup value. - E.G. V.IBM
+17 ;;XXX
