PRCORV ;WISC/DJM/BGJ-IFCAP VRQ REVIEW ROUTINE ;2/17/22 14:19
V ;;5.1;IFCAP;**7,227**;Oct 20, 2000;Build 1
;Per VHA Directive 6402, this routine should not be modified.
EN ; -- main entry point for PRCO VENDOR REVIEW
;First lets check if there are any VRQs to review. IF not - exit.
S COUNT=$O(^PRCF(422.2,"B","123-VRQ-01",0)) I COUNT'>0 G NODO
S COUNT=$P($G(^PRCF(422.2,COUNT,0)),U,2) I COUNT'>0 G NODO
K COUNT
;
N LN,PRCO,VALMAR,VALMBCK,VALMBG,VALMCNT,VALMHDR,VALMY
D TERM
D EN^VALM("PRCO VENDOR REVIEW")
Q
;
HDR ; -- header code
S VALMHDR(1)="VENDOR REQUESTs for review"
Q
;
INIT ; -- init variables and list array
N NAME,CNT,VDA,FMS,ALT,TAX,COUNT,LINENO,LIST
K ^TMP("PRCORV",$J)
S LIST=0,NAME=""
I $O(^PRC(440.3,"AD",NAME))="" W !,"No VRQs to review" Q
D CLEAN^VALM10
S COUNT=0,LINENO=0,NAME=""
F S NAME=$O(^PRC(440.3,"AD",NAME)) Q:NAME="" D
. S LIST=0
. F S LIST=$O(^PRC(440.3,"AD",NAME,LIST)) Q:LIST="" D
. . S NAME=$S($G(NAME)]"":NAME,1:$G(^PRC(440,LIST,0))) Q:NAME=""
. . I $G(^PRC(440.3,LIST,"VRQ"))']"" D Q
. . . K ^PRC(440.3,LIST)
. . . K ^PRC(440.3,"AD",NAME,LIST,LIST)
. . S VDA=0
. . F S VDA=$O(^PRC(440.3,"AD",NAME,LIST,VDA)) Q:VDA="" D
. . . S COUNT=COUNT+1
. . . S FMS=$P($G(^PRC(440,VDA,3)),U,4)
. . . S ALT=$P($G(^PRC(440,VDA,3)),U,5)
. . . S FMS=FMS_$S(ALT]"":"-"_FMS,1:"")
. . . S TAX=$P($G(^PRC(440,VDA,3)),U,8)
. . . S X=$$SETFLD^VALM1(COUNT,"","NUMBER")
. . . S X=$$SETFLD^VALM1(NAME,X,"VENDOR")
. . . S X=$$SETFLD^VALM1(FMS,X,"FMS VENDOR")
. . . S X=$$SETFLD^VALM1(TAX,X,"TAX ID/SSN")
. . . S LINENO=LINENO+1
. . . D SET^VALM10(COUNT,X,LINENO)
. . . S ^TMP("PRCORV",$J,LINENO)=COUNT_"^"_LIST
. . . Q
. . Q
. Q
S VALMCNT=COUNT
S LN=$O(^PRCF(422.2,"B","123-VRQ-01",0))
S $P(^PRCF(422.2,LN,0),U,2)=COUNT
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
D CLEAR^VALM1 K ^TMP($J,"PRCORV")
K ^TMP("PRCORV",$J)
Q
;
EXPND ; -- expand code
Q
;
TERM ; -- get terminal attributes
N X
I '$D(IOF)!('$G(IOST(0))) S IOP="HOME" D ^%ZIS K IOP
S X="IORVON;IORVOFF" D ENDR^%ZISS
S PRCO("RV1")=$G(IORVON),PRCO("RV0")=$G(IORVOFF)
S PRCO("XY")="N DX,DY S (DX,DY)=0 "_$G(^%ZOSF("XY"))
Q
;
SET(STRING,LINE,COLUMN,CLREND,ON,OFF) ; -- set array
S COLUMN=$S($G(COLUMN)>0:COLUMN,1:1)
I STRING="" D SET^VALM10(LINE,$J("",80),COLUMN)
I '$D(@VALMAR@(LINE,0)) D SET^VALM10(LINE,$J("",80),COLUMN)
D SET^VALM10(LINE,STRING,COLUMN)
I $G(ON)]""!($G(OFF)]"") D CNTRL^VALM10(LINE,COLUMN,$L(STRING),ON,OFF)
Q
;
NODO ;COME HERE IF THERE ARE NO VRQs TO REVIEW.
W !!,"There are no VRQs for you to review at this time.",!!
S DIR(0)="E"
S DIR("A")="Enter RETURN to continue"
D ^DIR
K DIR
Q
;
PRINT ;PRINTING OF A COMPLETE REVIEW OF VENDOR ENTRY
N %ZIS,AA,POP
D EN^VALM2(XQORNOD(0),"O")
Q:'$D(VALMY)
D FULL^VALM1
W @IOF
K IO("Q")
S %ZIS="MQ",%ZIS("A")="Select a printer: ",%ZIS("B")=""
S %ZIS("S")="S AA=$G(^%ZIS(1,Y,""SUBTYPE"")) I AA>0,$E($G(^%ZIS(2,AA,0)),1)=""P"""
D ^%ZIS
I POP W !!," No printer selected -- quitting." G PRINTQ
I $D(IO("Q")) K IO("Q") D G PRINTQ
. S ZTRTN="PRINT1^PRCORV"
. S ZTSAVE("VALMY(")=""
. S ZTSAVE("^TMP(""PRCORV"",$J,")=""
. S ZTDESC="Complete review of vender entry"
. D ^%ZTLOAD
. Q
;
PRINT1 ;ENTER HERE TO PRINT THE REPORT
N DIC,DA,DIQ,SPACE,%,%H,%I,X,Y,FIELD,PN,PRCOI,PRCOIN,IEN
S (PRCOI,PN)=0
;GET THE IEN FOR EACH ENTRY SELECTED
F S PRCOI=$O(VALMY(PRCOI)) Q:PRCOI'>0 D
. S PRCOIN=$G(^TMP("PRCORV",$J,PRCOI))
. S IEN=+$P(PRCOIN,U,2)
. S PN=PN+1
. D PRINT2
G PRINTQ
;
PRINT2 ;PRINT EACH ENTRY SELECTED HERE
K PRCORVP N DR
S DIC="^PRC(440,",DA=IEN,DR=".01:55",DIQ="PRCORVP",DIQ(0)="E"
D EN^DIQ1
S $P(SPACE," ",24)=" "
U IO
W:$Y>0 @IOF
I $D(ZTQUEUED) W:PN>1 !
W !!,?9,"VENDOR Review"
W ?38
D NOW^%DTC
D YX^%DTC
W Y
W ?70,"PAGE: "_PN
W !!,?11,"Vendor Name: "_$$FIELD(.01)
W !,?6,"Ordering Address: "_$$FIELD(1)
W:$$FIELD(2)]"" !,SPACE_$$FIELD(2)
S X=SPACE
S:$$FIELD(4.2)]"" X=X_$$FIELD(4.2)_", "
S:$$FIELD(4.4)]"" X=X_$$FIELD(4.4)_" "
S X=X_$S($L($$FIELD(4.6))=9:$E($$FIELD(4.6),1,5)_"-"_$E($$FIELD(4.6),6,9),1:$$FIELD(4.6))
W !,X
W !!,?14,"FMS Name: "_$$FIELD(34.5)
W !!,?7,"Payment ADDRESS: "_$$FIELD(17.3)
W !,SPACE,$$FIELD(17.4)
W:$$FIELD(17.5)]"" !,SPACE_$$FIELD(17.5)
W:$$FIELD(17.6)]"" !,SPACE_$$FIELD(17.6)
S X=SPACE
S:$$FIELD(17.7)]"" X=X_$$FIELD(17.7)_", "
S:$$FIELD(17.8)]"" X=X_$$FIELD(17.8)_" "
S X=X_$S($L($$FIELD(17.9))=9:$E($$FIELD(17.9),1,5)_"-"_$E($$FIELD(17.9),6,9),1:$$FIELD(17.9))
W !,X
W !!,"PAYMENT CONTACT PERSON: "_$$FIELD(17)
W !," PAYMENT PHONE NUMBER: "_$$FIELD(7.2)
W !!,?7,"FMS VENDOR CODE: "_$$FIELD(34)
W !,?10,"ALT-ADDR-IND: "_$$FIELD(35)
W !,?12,"TAX ID/SSN: "_$$FIELD(38)
W !,?8,"SSN/TAX ID IND: "_$$FIELD(39)
W !!,?8,"NON-RECURRING/"
W !,?6,"RECURRING VENDOR: "_$$FIELD(36)
W !!," 1099 VENDOR INDICATOR: "_$$FIELD(41)
W !,?11,"VENDOR TYPE: "_$$FIELD(44)
W !,?6,"DUN & BRADSTREET: "_$$FIELD(18.3)
W !,?19,"UEI: "_$$FIELD(55)
Q
;
PRINTQ S VALMBCK="R",VALMBG=1
S:$D(ZTQUEUED) ZTREQ="@"
D ^%ZISC
PRINTQ1 Q
;
FIELD(FIELD) ;FETCH EXTERNAL VALUE OF FIELD
;FOR RECORD 'IEN' FROM FILE 440
S FIELD=$G(PRCORVP(440,IEN,FIELD,"E"))
Q FIELD
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCORV 5415 printed Dec 13, 2024@02:12:04 Page 2
PRCORV ;WISC/DJM/BGJ-IFCAP VRQ REVIEW ROUTINE ;2/17/22 14:19
V ;;5.1;IFCAP;**7,227**;Oct 20, 2000;Build 1
+1 ;Per VHA Directive 6402, this routine should not be modified.
EN ; -- main entry point for PRCO VENDOR REVIEW
+1 ;First lets check if there are any VRQs to review. IF not - exit.
+2 SET COUNT=$ORDER(^PRCF(422.2,"B","123-VRQ-01",0))
IF COUNT'>0
GOTO NODO
+3 SET COUNT=$PIECE($GET(^PRCF(422.2,COUNT,0)),U,2)
IF COUNT'>0
GOTO NODO
+4 KILL COUNT
+5 ;
+6 NEW LN,PRCO,VALMAR,VALMBCK,VALMBG,VALMCNT,VALMHDR,VALMY
+7 DO TERM
+8 DO EN^VALM("PRCO VENDOR REVIEW")
+9 QUIT
+10 ;
HDR ; -- header code
+1 SET VALMHDR(1)="VENDOR REQUESTs for review"
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 NEW NAME,CNT,VDA,FMS,ALT,TAX,COUNT,LINENO,LIST
+2 KILL ^TMP("PRCORV",$JOB)
+3 SET LIST=0
SET NAME=""
+4 IF $ORDER(^PRC(440.3,"AD",NAME))=""
WRITE !,"No VRQs to review"
QUIT
+5 DO CLEAN^VALM10
+6 SET COUNT=0
SET LINENO=0
SET NAME=""
+7 FOR
SET NAME=$ORDER(^PRC(440.3,"AD",NAME))
if NAME=""
QUIT
Begin DoDot:1
+8 SET LIST=0
+9 FOR
SET LIST=$ORDER(^PRC(440.3,"AD",NAME,LIST))
if LIST=""
QUIT
Begin DoDot:2
+10 SET NAME=$SELECT($GET(NAME)]"":NAME,1:$GET(^PRC(440,LIST,0)))
if NAME=""
QUIT
+11 IF $GET(^PRC(440.3,LIST,"VRQ"))']""
Begin DoDot:3
+12 KILL ^PRC(440.3,LIST)
+13 KILL ^PRC(440.3,"AD",NAME,LIST,LIST)
End DoDot:3
QUIT
+14 SET VDA=0
+15 FOR
SET VDA=$ORDER(^PRC(440.3,"AD",NAME,LIST,VDA))
if VDA=""
QUIT
Begin DoDot:3
+16 SET COUNT=COUNT+1
+17 SET FMS=$PIECE($GET(^PRC(440,VDA,3)),U,4)
+18 SET ALT=$PIECE($GET(^PRC(440,VDA,3)),U,5)
+19 SET FMS=FMS_$SELECT(ALT]"":"-"_FMS,1:"")
+20 SET TAX=$PIECE($GET(^PRC(440,VDA,3)),U,8)
+21 SET X=$$SETFLD^VALM1(COUNT,"","NUMBER")
+22 SET X=$$SETFLD^VALM1(NAME,X,"VENDOR")
+23 SET X=$$SETFLD^VALM1(FMS,X,"FMS VENDOR")
+24 SET X=$$SETFLD^VALM1(TAX,X,"TAX ID/SSN")
+25 SET LINENO=LINENO+1
+26 DO SET^VALM10(COUNT,X,LINENO)
+27 SET ^TMP("PRCORV",$JOB,LINENO)=COUNT_"^"_LIST
+28 QUIT
End DoDot:3
+29 QUIT
End DoDot:2
+30 QUIT
End DoDot:1
+31 SET VALMCNT=COUNT
+32 SET LN=$ORDER(^PRCF(422.2,"B","123-VRQ-01",0))
+33 SET $PIECE(^PRCF(422.2,LN,0),U,2)=COUNT
+34 QUIT
+35 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 DO CLEAR^VALM1
KILL ^TMP($JOB,"PRCORV")
+2 KILL ^TMP("PRCORV",$JOB)
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
TERM ; -- get terminal attributes
+1 NEW X
+2 IF '$DATA(IOF)!('$GET(IOST(0)))
SET IOP="HOME"
DO ^%ZIS
KILL IOP
+3 SET X="IORVON;IORVOFF"
DO ENDR^%ZISS
+4 SET PRCO("RV1")=$GET(IORVON)
SET PRCO("RV0")=$GET(IORVOFF)
+5 SET PRCO("XY")="N DX,DY S (DX,DY)=0 "_$GET(^%ZOSF("XY"))
+6 QUIT
+7 ;
SET(STRING,LINE,COLUMN,CLREND,ON,OFF) ; -- set array
+1 SET COLUMN=$SELECT($GET(COLUMN)>0:COLUMN,1:1)
+2 IF STRING=""
DO SET^VALM10(LINE,$JUSTIFY("",80),COLUMN)
+3 IF '$DATA(@VALMAR@(LINE,0))
DO SET^VALM10(LINE,$JUSTIFY("",80),COLUMN)
+4 DO SET^VALM10(LINE,STRING,COLUMN)
+5 IF $GET(ON)]""!($GET(OFF)]"")
DO CNTRL^VALM10(LINE,COLUMN,$LENGTH(STRING),ON,OFF)
+6 QUIT
+7 ;
NODO ;COME HERE IF THERE ARE NO VRQs TO REVIEW.
+1 WRITE !!,"There are no VRQs for you to review at this time.",!!
+2 SET DIR(0)="E"
+3 SET DIR("A")="Enter RETURN to continue"
+4 DO ^DIR
+5 KILL DIR
+6 QUIT
+7 ;
PRINT ;PRINTING OF A COMPLETE REVIEW OF VENDOR ENTRY
+1 NEW %ZIS,AA,POP
+2 DO EN^VALM2(XQORNOD(0),"O")
+3 if '$DATA(VALMY)
QUIT
+4 DO FULL^VALM1
+5 WRITE @IOF
+6 KILL IO("Q")
+7 SET %ZIS="MQ"
SET %ZIS("A")="Select a printer: "
SET %ZIS("B")=""
+8 SET %ZIS("S")="S AA=$G(^%ZIS(1,Y,""SUBTYPE"")) I AA>0,$E($G(^%ZIS(2,AA,0)),1)=""P"""
+9 DO ^%ZIS
+10 IF POP
WRITE !!," No printer selected -- quitting."
GOTO PRINTQ
+11 IF $DATA(IO("Q"))
KILL IO("Q")
Begin DoDot:1
+12 SET ZTRTN="PRINT1^PRCORV"
+13 SET ZTSAVE("VALMY(")=""
+14 SET ZTSAVE("^TMP(""PRCORV"",$J,")=""
+15 SET ZTDESC="Complete review of vender entry"
+16 DO ^%ZTLOAD
+17 QUIT
End DoDot:1
GOTO PRINTQ
+18 ;
PRINT1 ;ENTER HERE TO PRINT THE REPORT
+1 NEW DIC,DA,DIQ,SPACE,%,%H,%I,X,Y,FIELD,PN,PRCOI,PRCOIN,IEN
+2 SET (PRCOI,PN)=0
+3 ;GET THE IEN FOR EACH ENTRY SELECTED
+4 FOR
SET PRCOI=$ORDER(VALMY(PRCOI))
if PRCOI'>0
QUIT
Begin DoDot:1
+5 SET PRCOIN=$GET(^TMP("PRCORV",$JOB,PRCOI))
+6 SET IEN=+$PIECE(PRCOIN,U,2)
+7 SET PN=PN+1
+8 DO PRINT2
End DoDot:1
+9 GOTO PRINTQ
+10 ;
PRINT2 ;PRINT EACH ENTRY SELECTED HERE
+1 KILL PRCORVP
NEW DR
+2 SET DIC="^PRC(440,"
SET DA=IEN
SET DR=".01:55"
SET DIQ="PRCORVP"
SET DIQ(0)="E"
+3 DO EN^DIQ1
+4 SET $PIECE(SPACE," ",24)=" "
+5 USE IO
+6 if $Y>0
WRITE @IOF
+7 IF $DATA(ZTQUEUED)
if PN>1
WRITE !
+8 WRITE !!,?9,"VENDOR Review"
+9 WRITE ?38
+10 DO NOW^%DTC
+11 DO YX^%DTC
+12 WRITE Y
+13 WRITE ?70,"PAGE: "_PN
+14 WRITE !!,?11,"Vendor Name: "_$$FIELD(.01)
+15 WRITE !,?6,"Ordering Address: "_$$FIELD(1)
+16 if $$FIELD(2)]""
WRITE !,SPACE_$$FIELD(2)
+17 SET X=SPACE
+18 if $$FIELD(4.2)]""
SET X=X_$$FIELD(4.2)_", "
+19 if $$FIELD(4.4)]""
SET X=X_$$FIELD(4.4)_" "
+20 SET X=X_$SELECT($LENGTH($$FIELD(4.6))=9:$EXTRACT($$FIELD(4.6),1,5)_"-"_$EXTRACT($$FIELD(4.6),6,9),1:$$FIELD(4.6))
+21 WRITE !,X
+22 WRITE !!,?14,"FMS Name: "_$$FIELD(34.5)
+23 WRITE !!,?7,"Payment ADDRESS: "_$$FIELD(17.3)
+24 WRITE !,SPACE,$$FIELD(17.4)
+25 if $$FIELD(17.5)]""
WRITE !,SPACE_$$FIELD(17.5)
+26 if $$FIELD(17.6)]""
WRITE !,SPACE_$$FIELD(17.6)
+27 SET X=SPACE
+28 if $$FIELD(17.7)]""
SET X=X_$$FIELD(17.7)_", "
+29 if $$FIELD(17.8)]""
SET X=X_$$FIELD(17.8)_" "
+30 SET X=X_$SELECT($LENGTH($$FIELD(17.9))=9:$EXTRACT($$FIELD(17.9),1,5)_"-"_$EXTRACT($$FIELD(17.9),6,9),1:$$FIELD(17.9))
+31 WRITE !,X
+32 WRITE !!,"PAYMENT CONTACT PERSON: "_$$FIELD(17)
+33 WRITE !," PAYMENT PHONE NUMBER: "_$$FIELD(7.2)
+34 WRITE !!,?7,"FMS VENDOR CODE: "_$$FIELD(34)
+35 WRITE !,?10,"ALT-ADDR-IND: "_$$FIELD(35)
+36 WRITE !,?12,"TAX ID/SSN: "_$$FIELD(38)
+37 WRITE !,?8,"SSN/TAX ID IND: "_$$FIELD(39)
+38 WRITE !!,?8,"NON-RECURRING/"
+39 WRITE !,?6,"RECURRING VENDOR: "_$$FIELD(36)
+40 WRITE !!," 1099 VENDOR INDICATOR: "_$$FIELD(41)
+41 WRITE !,?11,"VENDOR TYPE: "_$$FIELD(44)
+42 WRITE !,?6,"DUN & BRADSTREET: "_$$FIELD(18.3)
+43 WRITE !,?19,"UEI: "_$$FIELD(55)
+44 QUIT
+45 ;
PRINTQ SET VALMBCK="R"
SET VALMBG=1
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 DO ^%ZISC
PRINTQ1 QUIT
+1 ;
FIELD(FIELD) ;FETCH EXTERNAL VALUE OF FIELD
+1 ;FOR RECORD 'IEN' FROM FILE 440
+2 SET FIELD=$GET(PRCORVP(440,IEN,FIELD,"E"))
+3 QUIT FIELD
