Released PRC*5.1*124 SEQ #108 Extracted from mail message **KIDS**:PRC*5.1*124^ **INSTALL NAME** PRC*5.1*124 "BLD",5796,0) PRC*5.1*124^IFCAP^0^3081029^y "BLD",5796,1,0) ^^5^5^3081020^ "BLD",5796,1,1,0) 1. FGH - QT Adjustment for GIP Item - Reason Text "BLD",5796,1,2,0) "BLD",5796,1,3,0) 2. Purchase Card Information List Menu Option not working "BLD",5796,1,4,0) "BLD",5796,1,5,0) 3. ST+6^PRCHDP3 "BLD",5796,4,0) ^9.64PA^^ "BLD",5796,6.3) 2 "BLD",5796,"ABPKG") n "BLD",5796,"KRN",0) ^9.67PA^8989.52^19 "BLD",5796,"KRN",.4,0) .4 "BLD",5796,"KRN",.401,0) .401 "BLD",5796,"KRN",.401,"NM",0) ^9.68A^1^1 "BLD",5796,"KRN",.401,"NM",1,0) PRCH CARD INFOSORT FILE #440.5^440.5^0 "BLD",5796,"KRN",.401,"NM","B","PRCH CARD INFOSORT FILE #440.5",1) "BLD",5796,"KRN",.402,0) .402 "BLD",5796,"KRN",.403,0) .403 "BLD",5796,"KRN",.5,0) .5 "BLD",5796,"KRN",.84,0) .84 "BLD",5796,"KRN",3.6,0) 3.6 "BLD",5796,"KRN",3.8,0) 3.8 "BLD",5796,"KRN",9.2,0) 9.2 "BLD",5796,"KRN",9.8,0) 9.8 "BLD",5796,"KRN",9.8,"NM",0) ^9.68A^3^3 "BLD",5796,"KRN",9.8,"NM",1,0) PRCPAWU0^^0^B6821394 "BLD",5796,"KRN",9.8,"NM",2,0) PRCPEIQT^^0^B8819706 "BLD",5796,"KRN",9.8,"NM",3,0) PRCHAM4^^0^B23854643 "BLD",5796,"KRN",9.8,"NM","B","PRCHAM4",3) "BLD",5796,"KRN",9.8,"NM","B","PRCPAWU0",1) "BLD",5796,"KRN",9.8,"NM","B","PRCPEIQT",2) "BLD",5796,"KRN",19,0) 19 "BLD",5796,"KRN",19.1,0) 19.1 "BLD",5796,"KRN",101,0) 101 "BLD",5796,"KRN",409.61,0) 409.61 "BLD",5796,"KRN",771,0) 771 "BLD",5796,"KRN",870,0) 870 "BLD",5796,"KRN",8989.51,0) 8989.51 "BLD",5796,"KRN",8989.52,0) 8989.52 "BLD",5796,"KRN",8994,0) 8994 "BLD",5796,"KRN","B",.4,.4) "BLD",5796,"KRN","B",.401,.401) "BLD",5796,"KRN","B",.402,.402) "BLD",5796,"KRN","B",.403,.403) "BLD",5796,"KRN","B",.5,.5) "BLD",5796,"KRN","B",.84,.84) "BLD",5796,"KRN","B",3.6,3.6) "BLD",5796,"KRN","B",3.8,3.8) "BLD",5796,"KRN","B",9.2,9.2) "BLD",5796,"KRN","B",9.8,9.8) "BLD",5796,"KRN","B",19,19) "BLD",5796,"KRN","B",19.1,19.1) "BLD",5796,"KRN","B",101,101) "BLD",5796,"KRN","B",409.61,409.61) "BLD",5796,"KRN","B",771,771) "BLD",5796,"KRN","B",870,870) "BLD",5796,"KRN","B",8989.51,8989.51) "BLD",5796,"KRN","B",8989.52,8989.52) "BLD",5796,"KRN","B",8994,8994) "BLD",5796,"QUES",0) ^9.62^^ "BLD",5796,"REQB",0) ^9.611^^ "KRN",.401,1833,-1) 0^1 "KRN",.401,1833,0) PRCH CARD INFOSORT^3010409.0753^@^440.5^^@^3081029 "KRN",.401,1833,2,0) ^.4014^3^3 "KRN",.401,1833,2,1,0) 440.5^^CARD HOLDER^@#"7^^^^^^4 "KRN",.401,1833,2,1,"ASK") 1 "KRN",.401,1833,2,1,"CM") S Y(1)=$S($D(^PRC(440.5,D0,0)):^(0),1:"") S X=$S('$D(^VA(200,+$P(Y(1),U,8),0)):"",1:$P(^(0),U,1)) I D0>0 S DISX(1)=X "KRN",.401,1833,2,1,"F") Lz^M "KRN",.401,1833,2,1,"GET") S Y(1)=$S($D(^PRC(440.5,D0,0)):^(0),1:"") S X=$S('$D(^VA(200,+$P(Y(1),U,8),0)):"",1:$P(^(0),U,1)) I D0>0 S DISX(1)=X "KRN",.401,1833,2,1,"IX") ^PRC(440.5,"H",^PRC(440.5,^2 "KRN",.401,1833,2,1,"PTRIX") ^VA(200,"B", "KRN",.401,1833,2,1,"QCON") I (DISX(1)]]"Lz")&(DISX(1)']]"N") "KRN",.401,1833,2,1,"SER") 4.6250^0.8222 "KRN",.401,1833,2,1,"T") N^N "KRN",.401,1833,2,1,"TXT") CARD HOLDER from M to N "KRN",.401,1833,2,2,0) 440.5^10^PURCHASE CARD NAME^@^^^^^^4 "KRN",.401,1833,2,2,"ASK") 1 "KRN",.401,1833,2,2,"GET") S DISX(2)=$P($G(^PRC(440.5,D0,0)),U,11) "KRN",.401,1833,2,2,"IX") ^PRC(440.5,"G",^PRC(440.5,^2 "KRN",.401,1833,2,2,"QCON") I DISX(2)'="" "KRN",.401,1833,2,2,"SER") 0.2857^0.2222 "KRN",.401,1833,2,2,"TXT") PURCHASE CARD NAME not null "KRN",.401,1833,2,3,0) 440.5^10^STATION NUMBER^"15^^^^^^4 "KRN",.401,1833,2,3,"ASK") 1 "KRN",.401,1833,2,3,"CM") S Y(1)=$S($D(^PRC(440.5,D0,2)):^(2),1:"") S X=$S('$D(^PRC(411,+$P(Y(1),U,3),0)):"",1:$P(^(0),U,1)) I D0>0 S DISX(3)=X "KRN",.401,1833,2,3,"GET") S Y(1)=$S($D(^PRC(440.5,D0,2)):^(2),1:"") S X=$S('$D(^PRC(411,+$P(Y(1),U,3),0)):"",1:$P(^(0),U,1)) I D0>0 S DISX(3)=X "KRN",.401,1833,2,3,"IX") ^PRC(440.5,"G",^PRC(440.5,^2 "KRN",.401,1833,2,3,"QCON") I DISX(3)'="" "KRN",.401,1833,2,3,"TXT") STATION NUMBER not null "KRN",.401,1833,2,"B",440.5,1) "KRN",.401,1833,2,"B",440.5,2) "KRN",.401,1833,2,"B",440.5,3) "KRN",.401,1833,"%D",0) ^.4012^1^1^3081029^^^^ "KRN",.401,1833,"%D",1,0) Sort template for every card by user and station number. "MBREQ") 0 "ORD",6,.401) .401;6;;;EDEOUT^DIFROMSO(.401,DA,"",XPDA);FPRE^DIFROMSI(.401,"",XPDA);EPRE^DIFROMSI(.401,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.401,DA,"",XPDA);DEL^DIFROMSK(.401,"",%) "ORD",6,.401,0) SORT TEMPLATE "PKG",455,-1) 1^1 "PKG",455,0) IFCAP^PRC^IFCAP System Files "PKG",455,20,0) ^9.402P^^ "PKG",455,22,0) ^9.49I^1^1 "PKG",455,22,1,0) 5.1^3001012^3001019^68 "PKG",455,22,1,"PAH",1,0) 124^3081029 "PKG",455,22,1,"PAH",1,1,0) ^^5^5^3081029 "PKG",455,22,1,"PAH",1,1,1,0) 1. FGH - QT Adjustment for GIP Item - Reason Text "PKG",455,22,1,"PAH",1,1,2,0) "PKG",455,22,1,"PAH",1,1,3,0) 2. Purchase Card Information List Menu Option not working "PKG",455,22,1,"PAH",1,1,4,0) "PKG",455,22,1,"PAH",1,1,5,0) 3. ST+6^PRCHDP3 "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 3 "RTN","PRCHAM4") 0^3^B23854643^B23457835 "RTN","PRCHAM4",1,0) PRCHAM4 ;WISC/AKS,ID/RSD,SF-ISC/TKW-ADJUSTMENT VOUCHER ;6/8/96 13:06 "RTN","PRCHAM4",2,0) V ;;5.1;IFCAP;**124**;Oct 20, 2000;Build 2 "RTN","PRCHAM4",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCHAM4",4,0) EN ;ADJUSTMENT VOUCHER "RTN","PRCHAM4",5,0) I $D(^PRC(443.6,PRCHPO)) D Q "RTN","PRCHAM4",6,0) .W !!,"There is a pending amendment against this purchase order." Q "RTN","PRCHAM4",7,0) S PRCHAV="" D ENAV^PRCHAM Q:'$D(PRCHPO) "RTN","PRCHAM4",8,0) PAR S DIC="^PRC(442,PRCHPO,11,",DIC(0)="QEANZ" "RTN","PRCHAM4",9,0) S DIC("S")="I $P(^PRC(442,PRCHPO,11,+Y,0),U,12)'<0" D ^DIC K DIC "RTN","PRCHAM4",10,0) ;I $G(PRCHAUTH)=1 S DIC("S")="I $P(^PRC(442,PRCHPO,11,+Y,0),U,12)'<0,$P(^PRC(442,PRCHPO,23),U,11)=""P""" "RTN","PRCHAM4",11,0) ;I $G(PRCHAUTH)=2 S DIC("S")="I $P(^PRC(442,PRCHPO,11,+Y,0),U,12)'<0,$P(^PRC(442,PRCHPO,23),U,11)=""D""" "RTN","PRCHAM4",12,0) G:Y<0 Q^PRCHAM "RTN","PRCHAM4",13,0) I $P(^PRC(442,PRCHPO,11,+Y,0),U,6)="",$P($G(^PRC(442,PRCHPO,0)),U,2)'=25,'$G(PRCHAUTH) W !,"This Receiving Report has not been processed in Fiscal Service." G PAR "RTN","PRCHAM4",14,0) S (PRCHRPTO,PRCHRPT)=+Y,PRCHAV0=Y(0),PRCHRD=$P(Y(0),U) "RTN","PRCHAM4",15,0) S (PRCHRTT,PRCHRT)=0 "RTN","PRCHAM4",16,0) S:$D(^PRC(442,PRCHPO,11,PRCHRPTO,1)) PRCHAV1=^(1),$P(PRCHAV1,U,16)=PRCHRPTO "RTN","PRCHAM4",17,0) S PRCHSAM1=$P(PRCHAV0,U,3),PRCHSAM2=$P(PRCHAV0,U,5) "RTN","PRCHAM4",18,0) D NOW^%DTC "RTN","PRCHAM4",19,0) I X>($P(^PRC(442,PRCHPO,11,PRCHRPTO,0),U)+30) D I %'=1 G Q^PRCHAM "RTN","PRCHAM4",20,0) .W !!,?10,"This partial receipt is more than 30 days old." "RTN","PRCHAM4",21,0) .W !,?10,"Please check payment status with Fiscal.",!," " "RTN","PRCHAM4",22,0) .S %="",%A=" Would you like to continue? ",%B="" D ^PRCFYN "RTN","PRCHAM4",23,0) S ^TMP("PRCHW",$J,1)="Adjustment Voucher for Purchase Order "_$P(PRCH(0),U) "RTN","PRCHAM4",24,0) S (PRCHII,PRCHNN)=0 F S PRCHNN=$O(^PRC(442,PRCHPO,11,PRCHNN)) Q:'PRCHNN S PRCHII=PRCHII+1 "RTN","PRCHAM4",25,0) S PRCHRPTN=PRCHII+1,PRCHATOT=0 "RTN","PRCHAM4",26,0) S PRCHJ=3,PRCHL1="*",(PRCHO,PRCHN,PRCHL2)="" D EN^PRCHAM "RTN","PRCHAM4",27,0) ITEM S DIC("S")="I $O(^PRC(443.6,PRCHPO,2,""AB"",PRCHRD,+Y,0))" "RTN","PRCHAM4",28,0) K PRCHI,^TMP("PRCHW",$J) D MV^PRCHAM2,EN^PRCHAM2 K DIC "RTN","PRCHAM4",29,0) I '$D(PRCHNFLG) G Q^PRCHAM "RTN","PRCHAM4",30,0) G LST:Y<0,ITEM:'$D(^PRC(443.6,PRCHPO,2,+PRCHI,2)) "RTN","PRCHAM4",31,0) S PRCHI(0)=^PRC(443.6,PRCHPO,2,+PRCHI,0),PRCHI(2)=^(2),I=PRCHJ "RTN","PRCHAM4",32,0) D MES^PRCHAM2 S PRCHAV=+$O(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,+PRCHI,0)) "RTN","PRCHAM4",33,0) G:'$D(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0)) ITEM S (PRCHITR,Y)=^(0) "RTN","PRCHAM4",34,0) ;S PRCHO=$S($P(Y,U,7):$P(Y,U,7),1:$P(Y,U,2)),PRCHAMT1=$P(Y,U,3) "RTN","PRCHAM4",35,0) S PRCHO=$P(Y,U,2),PRCHAMT1=$P(Y,U,3) "RTN","PRCHAM4",36,0) I $P(Y,U,7)]"" S PRCHO=$P(Y,U,7),PRCHAMT1=$P(Y,U,8) "RTN","PRCHAM4",37,0) S PRCHDA=$P(Y,U,5),PRCHK=K+1 "RTN","PRCHAM4",38,0) S ^TMP("PRCHW",$J,PRCHK)=" ORIGINALLY QTY RECEIVED = "_PRCHO_" ,COST = $ "_PRCHAMT1 "RTN","PRCHAM4",39,0) S PRCHK=PRCHK+1 D EN2^PRCHAM44 G ITEM:'$D(X) "RTN","PRCHAM4",40,0) S PRCHN=PRCHXX G:PRCHO=+PRCHN ITEM "RTN","PRCHAM4",41,0) S PRCHADAM=$S($P(PRCHITR,U,8):$P(PRCHITR,U,8),1:$P(PRCHITR,U,3))+PRCHAMT1 "RTN","PRCHAM4",42,0) S $P(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAVLD,0),U,8)=PRCHADAM "RTN","PRCHAM4",43,0) S ^TMP("PRCHW",$J,PRCHK)=" will now read: QTY RECEIVED="_PRCHQTY_", COST=$"_PRCHADAM "RTN","PRCHAM4",44,0) S PRCHJ=PRCHK+1,PRCHL1="*",PRCHL2="",PRCHJ=1 D EN^PRCHAM S PRCHATOT=PRCHATOT+1 G ITEM "RTN","PRCHAM4",45,0) LST S (PRCHAMT1,PRCHDA)=0,PRCHAVA=$P(PRCHAV0,U,3)+$P(PRCHAV0,U,5) "RTN","PRCHAM4",46,0) I 'PRCHCHK!(PRCHATOT=0) D Q G Q^PRCHAM "RTN","PRCHAM4",47,0) S I=0 F S I=$O(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I)) Q:'I D "RTN","PRCHAM4",48,0) .S J=0 F S J=$O(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I,J)) Q:'J D "RTN","PRCHAM4",49,0) ..S PRCHAV=J I $D(^PRC(443.6,PRCHPO,2,I,0)),$D(^(2)) S PRCHRS=$P(^(2),U,7) I $D(^(3,PRCHAV,0)) S (PRCHITSB,Y)=^(0) D SUB "RTN","PRCHAM4",50,0) D TM^PRCHREC2,EN2^PRCHREC S K=1 "RTN","PRCHAM4",51,0) S ^TMP("PRCHW",$J,K)=" Vendor: "_$P(^PRC(440,$P(^PRC(442,PRCHPO,1),U),0),U),K=K+1 "RTN","PRCHAM4",52,0) S ^TMP("PRCHW",$J,K)=" APPROPRIATION: "_$P(^PRC(442,PRCHPO,0),U,4),K=K+1 "RTN","PRCHAM4",53,0) S ^TMP("PRCHW",$J,K)=" This Receiving Report will now read: ",K=K+1 "RTN","PRCHAM4",54,0) I PRCHDA D "RTN","PRCHAM4",55,0) .S ^TMP("PRCHW",$J,K)=" Discounted Amount: "_PRCHDA,K=K+1 "RTN","PRCHAM4",56,0) S ^TMP("PRCHW",$J,K)=" Total Amount: "_PRCHRAM "RTN","PRCHAM4",57,0) I PRCHRT S PRCHRTT=PRCHRAM*PRCHRT D "RTN","PRCHAM4",58,0) .S ^TMP("PRCHW",$J,K+1)=" Term Discount Amount: "_$J(PRCHRTT,8,2) "RTN","PRCHAM4",59,0) .S ^TMP("PRCHW",$J,K+2)=" Net Amount: "_$J(PRCHRAMN,10,2) "RTN","PRCHAM4",60,0) S (PRCHAMT1,PRCHDA)=0,PRCHAVA=$P(PRCHAV0,U,3)+$P(PRCHAV0,U,5) K PRCHR "RTN","PRCHAM4",61,0) ;I 'PRCHCHK D Q G Q^PRCHAM "RTN","PRCHAM4",62,0) S I=0 F S I=$O(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I)) Q:'I D "RTN","PRCHAM4",63,0) .S J=0 F S J=$O(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I,J)) Q:'J D "RTN","PRCHAM4",64,0) ..I '$D(^PRC(442,PRCHPO,11,J)) S PRCHAV=J I $D(^PRC(443.6,PRCHPO,2,I,0)),$D(^(2)) S PRCHRS=$P(^(2),U,7) I $D(^(3,PRCHAV,0)) S (PRCHITSB,Y)=^(0) D SUB "RTN","PRCHAM4",65,0) D TM^PRCHREC2,EN2^PRCHREC S K=1 "RTN","PRCHAM4",66,0) S $P(PRCHAV0,U,2,5)=PRCHR(1)_U_PRCHR(2) "RTN","PRCHAM4",67,0) S X=$P(PRCHAV0,U,9) S:X]""&($D(PRCHAF)) $P(PRCHAV0,U,9)="" "RTN","PRCHAM4",68,0) S $P(PRCHAV0,U,19)="" "RTN","PRCHAM4",69,0) S $P(PRCHAV0,U,10)=$S($D(PRCHROV):"Y",1:""),$P(PRCHAV0,U,12)=PRCHRAM "RTN","PRCHAM4",70,0) S X=$P(^PRC(443.6,PRCHPO,0),U,17),X=X-PRCHAVA,$P(^(0),U,17)=X "RTN","PRCHAM4",71,0) S $P(PRCHAV0,U,6)="",$P(PRCHAV0,U,9)="" "RTN","PRCHAM4",72,0) S ^PRC(443.6,PRCHPO,11,PRCHRPT,0)=PRCHAV0,PRCHL1="*" "RTN","PRCHAM4",73,0) S:$D(PRCHAV1) ^PRC(443.6,PRCHPO,11,PRCHRPT,1)=PRCHAV1 "RTN","PRCHAM4",74,0) S (PRCHO,PRCHN,PRCHL2)="" D EN^PRCHAM,Q G EN2^PRCHAM "RTN","PRCHAM4",75,0) SUB S PRCHDA=PRCHDA+$P(Y,U,5) S:PRCHRS="" PRCHRS="**" "RTN","PRCHAM4",76,0) S:'$D(PRCHR("SA",PRCHRS)) PRCHR("SA",PRCHRS)=0 "RTN","PRCHAM4",77,0) S PRCHR("SA",PRCHRS)=PRCHR("SA",PRCHRS)+$P(Y,U,3)-$P(Y,U,5) Q "RTN","PRCHAM4",78,0) SETC ;IF ESTIMATED ORDER, PARTIAL ORDER RECEIVED, RESET 'C' X-REF ON ALL ITEMS "RTN","PRCHAM4",79,0) Q:'$D(^PRC(442,PRCHPO,7)) Q:$P(^(7),U,3)'="Y" Q:$P(^(7),U,2)'=26 "RTN","PRCHAM4",80,0) F I=0:0 S I=$O(^PRC(442,PRCHPO,2,I)) Q:'I I $D(^(I,0)) D "RTN","PRCHAM4",81,0) .S X=+^(0),PRCHX(X,X)="^PRC(442,PRCHPO,2,""C"",X,"_I_")" "RTN","PRCHAM4",82,0) Q "RTN","PRCHAM4",83,0) W1 W:$E(X)'="?" " ??",$C(7) "RTN","PRCHAM4",84,0) W !,"Enter the quantity (a number between 0 & 999,999 with up to two decimal places)" Q "RTN","PRCHAM4",85,0) Q K PRCHAMT1,PRCHDA,PRCHRD,PRCHR,PRCHRPT,PRCHRES,PRCHRAM,PRCHRAMN,PRCHRT,PRCHATOT "RTN","PRCHAM4",86,0) K PRCHRT2,PRCHRS,PRCHRQ,PRCHRQ1,PRCHROV,PRCHAV0,PRCHAVA,PRCHAF,PRCHRTT "RTN","PRCHAM4",87,0) QUIT "RTN","PRCHAM4",88,0) EN2Q K X "RTN","PRCHAM4",89,0) QUIT "RTN","PRCPAWU0") 0^1^B6821394^B6469755 "RTN","PRCPAWU0",1,0) PRCPAWU0 ;WISC/RFJ-adjustment utilities ;11 Mar 94 "RTN","PRCPAWU0",2,0) ;;5.1;IFCAP;**124**;Oct 20, 2000;Build 2 "RTN","PRCPAWU0",3,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","PRCPAWU0",4,0) Q "RTN","PRCPAWU0",5,0) ; "RTN","PRCPAWU0",6,0) ; "RTN","PRCPAWU0",7,0) ITEM() ; select item from tmp($j,"prcpawap","item",*itemnumber*) global "RTN","PRCPAWU0",8,0) N %,COUNT,ITEMDA,PRCPFLAG,X "RTN","PRCPAWU0",9,0) F D Q:ITEMDA'="" "RTN","PRCPAWU0",10,0) . W !," Select ITEM: " "RTN","PRCPAWU0",11,0) . R X:DTIME I '$T!(X["^")!(X="") S ITEMDA="^" Q "RTN","PRCPAWU0",12,0) . I $D(^TMP($J,"PRCPAWAP","ITEM",+X)) S ITEMDA=+X Q "RTN","PRCPAWU0",13,0) . S ITEMDA="" "RTN","PRCPAWU0",14,0) . W !,"Select the ITEM NUMBER from the list below:",! "RTN","PRCPAWU0",15,0) . S COUNT=0,X="" F S X=$O(^TMP($J,"PRCPAWAP","ITEM",X)) Q:X=""!($G(PRCPFLAG)) D "RTN","PRCPAWU0",16,0) . . W " ITEM NUMBER: ",X,?23,$E($$DESCR^PRCPUX1(PRCP("I"),+X),1,30),?58,"NSN: ",$$NSN^PRCPUX1(+X) S COUNT=COUNT+1 "RTN","PRCPAWU0",17,0) . . I COUNT#20=0 D P^PRCPUREP S %="",$P(%," ",80)="" W $C(13),% "RTN","PRCPAWU0",18,0) . . W ! "RTN","PRCPAWU0",19,0) Q ITEMDA "RTN","PRCPAWU0",20,0) ; "RTN","PRCPAWU0",21,0) ; "RTN","PRCPAWU0",22,0) VOUCHER() ; enter reference voucher number "RTN","PRCPAWU0",23,0) N DIR,X,Y "RTN","PRCPAWU0",24,0) S DIR(0)="FA^5:5",DIR("A")=" VOUCHER NUMBER: ",DIR("A",1)=" >> Enter DOCUMENT IDENTIFIER number. <<" "RTN","PRCPAWU0",25,0) D ^DIR "RTN","PRCPAWU0",26,0) Q Y "RTN","PRCPAWU0",27,0) ; "RTN","PRCPAWU0",28,0) ; "RTN","PRCPAWU0",29,0) QTY(LOW,HIGH) ; adjust quantity from low to high "RTN","PRCPAWU0",30,0) ; return qty, qty=^ for ^ entered "RTN","PRCPAWU0",31,0) N DIR,X,Y "RTN","PRCPAWU0",32,0) S DIR(0)="NA^"_LOW_":"_HIGH_":0",DIR("A")=" ADJUSTED QUANTITY: ",DIR("B")=0 "RTN","PRCPAWU0",33,0) S DIR("A",1)=" >> Enter the adjusted quantity in the range "_LOW_" to "_HIGH_". <<" "RTN","PRCPAWU0",34,0) D ^DIR "RTN","PRCPAWU0",35,0) Q Y "RTN","PRCPAWU0",36,0) ; "RTN","PRCPAWU0",37,0) ; "RTN","PRCPAWU0",38,0) VALUE(LOW,HIGH,PROMPT,DEFAULT) ; adjust value from low to high "RTN","PRCPAWU0",39,0) ; ask in prompt with default value "RTN","PRCPAWU0",40,0) N DIR,X,Y "RTN","PRCPAWU0",41,0) S DIR(0)="NAO^"_LOW_":"_HIGH_":2",DIR("A")=" ADJUSTED TOTAL"_PROMPT_" VALUE: " S:DEFAULT'="" DIR("B")=DEFAULT "RTN","PRCPAWU0",42,0) S DIR("A",1)=" >> Enter the adjusted value in the range "_LOW_" to "_HIGH_". <<" "RTN","PRCPAWU0",43,0) D ^DIR "RTN","PRCPAWU0",44,0) Q Y "RTN","PRCPAWU0",45,0) ; "RTN","PRCPAWU0",46,0) ; "RTN","PRCPAWU0",47,0) REASON(DEFAULT,NODISV) ; enter reason text "RTN","PRCPAWU0",48,0) ;NODISV=1 will stop default reason from ^DISV "RTN","PRCPAWU0",49,0) N DIR,REASON,X,Y "RTN","PRCPAWU0",50,0) I DEFAULT="",'$G(NODISV) S REASON=$G(^DISV(+$G(DUZ),"PRCPAWU0","REASON")) "RTN","PRCPAWU0",51,0) S DIR(0)="F^1:80",DIR("A")=" REASON TEXT",DIR("B")=$S(DEFAULT=""&'$G(NODISV):$G(REASON),1:DEFAULT) "RTN","PRCPAWU0",52,0) S DIR("A",1)=" >> Enter the reason text which will appear on the transaction register. <<" "RTN","PRCPAWU0",53,0) D ^DIR "RTN","PRCPAWU0",54,0) I (DEFAULT=""&'$G(NODISV)),Y'["^" S ^DISV(DUZ,"PRCPAWU0","REASON")=Y "RTN","PRCPAWU0",55,0) Q Y "RTN","PRCPEIQT") 0^2^B8819706^B8813072 "RTN","PRCPEIQT",1,0) PRCPEIQT ;WISC/RFJ-edit quantities, dueins, costs ; 5/4/99 3:40pm "RTN","PRCPEIQT",2,0) V ;;5.1;IFCAP;**124**;Oct 20, 2000;Build 2 "RTN","PRCPEIQT",3,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","PRCPEIQT",4,0) Q "RTN","PRCPEIQT",5,0) ; "RTN","PRCPEIQT",6,0) ; "RTN","PRCPEIQT",7,0) QTY(PRCPINPT,ITEMDA) ; adjust primary or secondary quantity "RTN","PRCPEIQT",8,0) N %,ITEMDATA,ORDERNO,PRCPEIQT,PRCPID,QTY,REASON,VALUE,X,Y "RTN","PRCPEIQT",9,0) S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0)) I ITEMDATA="" Q "RTN","PRCPEIQT",10,0) W !!?3,"QTY ON-HAND (in ",$$UNIT^PRCPUX1(PRCPINPT,ITEMDA," per "),"): ",+$P(ITEMDATA,"^",7) "RTN","PRCPEIQT",11,0) W !?10,"x",?16,"AVERAGE COST: ",$J(+$P(ITEMDATA,"^",22),0,3) "RTN","PRCPEIQT",12,0) W !?10,"=",?13,"INVENTORY VALUE: ",$J(+$P(ITEMDATA,"^",27),0,2),! "RTN","PRCPEIQT",13,0) S QTY=$$QTY^PRCPAWU0(-99999,99999) Q:QTY["^" "RTN","PRCPEIQT",14,0) W ! S VALUE=$$VALUE^PRCPAWU0(-9999999.99,9999999.99,"",0) Q:VALUE["^" "RTN","PRCPEIQT",15,0) S QTY=+QTY,VALUE=+VALUE I QTY=0,VALUE=0 Q "RTN","PRCPEIQT",16,0) W ! S REASON=$$REASON^PRCPAWU0("",1) Q:REASON["^" "RTN","PRCPEIQT",17,0) S ORDERNO=$$ORDERNO^PRCPUTRX(PRCPINPT) "RTN","PRCPEIQT",18,0) K PRCPEIQT S PRCPEIQT("QTY")=QTY,PRCPEIQT("INVVAL")=VALUE,PRCPEIQT("SELVAL")=0,PRCPEIQT("REASON")="0:"_REASON,PRCPEIQT("2237PO")="" "RTN","PRCPEIQT",19,0) D ITEM^PRCPUUIW(PRCPINPT,ITEMDA,"A",ORDERNO,.PRCPEIQT) "RTN","PRCPEIQT",20,0) Q "RTN","PRCPEIQT",21,0) ; "RTN","PRCPEIQT",22,0) ; "RTN","PRCPEIQT",23,0) DUEIN(PRCPINPT,ITEMDA) ; change primary or secondary due-ins "RTN","PRCPEIQT",24,0) N %,%H,D,D0,D1,DA,DD,DDC,DDH,DI,DIC,DIE,DIX,DIY,DIZ,DO,DQ,DR,DZ,ITEMDATA,PRCPTYPE,X,Y,Z "RTN","PRCPEIQT",25,0) S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0)) I ITEMDATA="" Q "RTN","PRCPEIQT",26,0) S PRCPTYPE=$P(^PRCP(445,PRCPINPT,0),"^",3) "RTN","PRCPEIQT",27,0) W !!?3,"QTY DUE-IN (in ",$$UNIT^PRCPUX1(PRCPINPT,ITEMDA," per "),"): ",$$GETIN^PRCPUDUE(PRCPINPT,ITEMDA),! "RTN","PRCPEIQT",28,0) S:'$D(^PRCP(445,PRCPINPT,1,ITEMDA,7,0)) ^(0)="^445.09P^^" "RTN","PRCPEIQT",29,0) S (DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,",DA(1)=PRCPINPT,DA=ITEMDA,DR=$S(PRCPTYPE="S":8.1,1:20) "RTN","PRCPEIQT",30,0) D ^DIE "RTN","PRCPEIQT",31,0) I PRCPTYPE="S" Q "RTN","PRCPEIQT",32,0) S (X,Y)=0 F S X=$O(^PRCP(445,PRCPINPT,1,ITEMDA,7,X)) Q:'X S Y=Y+$P($G(^(X,0)),"^",2) "RTN","PRCPEIQT",33,0) S X=Y-$$GETIN^PRCPUDUE(PRCPINPT,ITEMDA) I X W !?5,"...total DUE-IN QUANTITY adjusted (by: ",X,") to: ",Y D SETIN^PRCPUDUE(PRCPINPT,ITEMDA,X),R^PRCPUREP "RTN","PRCPEIQT",34,0) Q "RTN","PRCPEIQT",35,0) ; "RTN","PRCPEIQT",36,0) ; "RTN","PRCPEIQT",37,0) COSTEDIT(PRCPINPT,ITEMDA) ; edit last cost for invpt and item "RTN","PRCPEIQT",38,0) N %,D,D0,DA,DI,DIC,DIE,DQ,DR,DZ,X,X1,Y,Y1 "RTN","PRCPEIQT",39,0) CE1 S DA(1)=PRCPINPT,DA=ITEMDA,(DIC,DIE)="^PRCP(445,"_PRCPINPT_",1,",DR="4.7LAST COST;" "RTN","PRCPEIQT",40,0) D ^DIE "RTN","PRCPEIQT",41,0) S X1=$P(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",22),X=$P(^PRCP(445,PRCPINPT,1,ITEMDA,0),"^",15),Y=X1*1.1,Y1=X1/1.1 "RTN","PRCPEIQT",42,0) I X>Y!(X