Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCORV

PRCORV.m

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