- 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 Feb 18, 2025@23:38:27 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