Released PRC*5.1*184 SEQ #168 Extracted from mail message **KIDS**:PRC*5.1*184^ **INSTALL NAME** PRC*5.1*184 "BLD",7367,0) PRC*5.1*184^IFCAP^0^3140311^y "BLD",7367,1,0) ^^6^6^3140110^^ "BLD",7367,1,1,0) "BLD",7367,1,2,0) 1. Purchase Card and Delivery orders reaching 2237 max on backend filing "BLD",7367,1,3,0) "BLD",7367,1,4,0) 2. Purchase Card accrual issue from one quarter to next with Carry Forward "BLD",7367,1,5,0) "BLD",7367,1,6,0) 3. Documentation error in Control Point Official's Manual "BLD",7367,4,0) ^9.64PA^^ "BLD",7367,6.3) 8 "BLD",7367,"ABPKG") n "BLD",7367,"KRN",0) ^9.67PA^779.2^20 "BLD",7367,"KRN",.4,0) .4 "BLD",7367,"KRN",.401,0) .401 "BLD",7367,"KRN",.402,0) .402 "BLD",7367,"KRN",.402,"NM",0) ^9.68A^4^4 "BLD",7367,"KRN",.402,"NM",1,0) PRCHSIMP FILE #442^442^0 "BLD",7367,"KRN",.402,"NM",2,0) PRCH DETAILED PURCHASE CARD FILE #442^442^0 "BLD",7367,"KRN",.402,"NM",3,0) PRCH PC DIRECT DELIVERY FILE #442^442^0 "BLD",7367,"KRN",.402,"NM",4,0) PRCH DELIVERY ORDER FILE #442^442^0 "BLD",7367,"KRN",.402,"NM","B","PRCH DELIVERY ORDER FILE #442",4) "BLD",7367,"KRN",.402,"NM","B","PRCH DETAILED PURCHASE CARD FILE #442",2) "BLD",7367,"KRN",.402,"NM","B","PRCH PC DIRECT DELIVERY FILE #442",3) "BLD",7367,"KRN",.402,"NM","B","PRCHSIMP FILE #442",1) "BLD",7367,"KRN",.403,0) .403 "BLD",7367,"KRN",.5,0) .5 "BLD",7367,"KRN",.84,0) .84 "BLD",7367,"KRN",3.6,0) 3.6 "BLD",7367,"KRN",3.8,0) 3.8 "BLD",7367,"KRN",9.2,0) 9.2 "BLD",7367,"KRN",9.8,0) 9.8 "BLD",7367,"KRN",9.8,"NM",0) ^9.68A^4^4 "BLD",7367,"KRN",9.8,"NM",1,0) PRCHNPO^^0^B62074705 "BLD",7367,"KRN",9.8,"NM",2,0) PRCH1A3^^0^B27339623 "BLD",7367,"KRN",9.8,"NM",3,0) PRCHNPOB^^0^B4314054 "BLD",7367,"KRN",9.8,"NM",4,0) PRCSEB^^0^B21871782 "BLD",7367,"KRN",9.8,"NM","B","PRCH1A3",2) "BLD",7367,"KRN",9.8,"NM","B","PRCHNPO",1) "BLD",7367,"KRN",9.8,"NM","B","PRCHNPOB",3) "BLD",7367,"KRN",9.8,"NM","B","PRCSEB",4) "BLD",7367,"KRN",19,0) 19 "BLD",7367,"KRN",19,"NM",0) ^9.68A^^ "BLD",7367,"KRN",19.1,0) 19.1 "BLD",7367,"KRN",101,0) 101 "BLD",7367,"KRN",409.61,0) 409.61 "BLD",7367,"KRN",771,0) 771 "BLD",7367,"KRN",779.2,0) 779.2 "BLD",7367,"KRN",870,0) 870 "BLD",7367,"KRN",8989.51,0) 8989.51 "BLD",7367,"KRN",8989.52,0) 8989.52 "BLD",7367,"KRN",8994,0) 8994 "BLD",7367,"KRN","B",.4,.4) "BLD",7367,"KRN","B",.401,.401) "BLD",7367,"KRN","B",.402,.402) "BLD",7367,"KRN","B",.403,.403) "BLD",7367,"KRN","B",.5,.5) "BLD",7367,"KRN","B",.84,.84) "BLD",7367,"KRN","B",3.6,3.6) "BLD",7367,"KRN","B",3.8,3.8) "BLD",7367,"KRN","B",9.2,9.2) "BLD",7367,"KRN","B",9.8,9.8) "BLD",7367,"KRN","B",19,19) "BLD",7367,"KRN","B",19.1,19.1) "BLD",7367,"KRN","B",101,101) "BLD",7367,"KRN","B",409.61,409.61) "BLD",7367,"KRN","B",771,771) "BLD",7367,"KRN","B",779.2,779.2) "BLD",7367,"KRN","B",870,870) "BLD",7367,"KRN","B",8989.51,8989.51) "BLD",7367,"KRN","B",8989.52,8989.52) "BLD",7367,"KRN","B",8994,8994) "BLD",7367,"QDEF") ^^^^^^^^^^YES "BLD",7367,"QUES",0) ^9.62^^ "BLD",7367,"REQB",0) ^9.611^3^2 "BLD",7367,"REQB",1,0) PRC*5.1*123^2 "BLD",7367,"REQB",3,0) PRC*5.1*174^2 "BLD",7367,"REQB","B","PRC*5.1*123",1) "BLD",7367,"REQB","B","PRC*5.1*174",3) "KRN",.402,2663,-1) 0^2 "KRN",.402,2663,0) PRCH DETAILED PURCHASE CARD^3130918.1432^^442^^^3140207 "KRN",.402,2663,"DIAB",3,0,442,7) PCDO VENDOR;REQ "KRN",.402,2663,"DIAB",7,0,442,2) SUBSTATION;REQ "KRN",.402,2663,"DIAB",10,1,442.01,8) FEDERAL SUPPLY CLASSIFICATION;T "KRN",.402,2663,"DR",1,442) Q:'$D(PRC("SITE")) S (PRCHN("SVC"),PRCHN("CC"),PRCHN("SC"),PRCHN("INV"))="",PRCHN("SFC")=+$P(^PRC(442,DA,0),U,19),PRCHN("FOB")=$S($D(^(1)):$P(^(1),U,6),1:""),PRCHN(12)=$S($D(^PRC(442,DA,12)):^(12),1:""); "KRN",.402,2663,"DR",1,442,1) S PRCHPONO=$P(^PRC(442,DA,0),U,1),PRCHSTN=$P(PRCHPONO,"-") S PRCHIEN=DA;S PRCX=$O(^PRC(411,PRC("SITE"),1,0)) S:$G(PRCX)]"" PRCY=$P($G(^PRC(411,PRC("SITE"),1,PRCX,0)),U) K PRCX;D EN2^PRCHNPO6;S PRCHDUZ=$P(^VA(200,DUZ,0),U,1); "KRN",.402,2663,"DR",1,442,2) 16////^S X=DUZ;56////^S X=DUZ;.02///^S X=25;48///^S X="P";63///^S X=1;I '$D(^PRC(411,"UP",PRC("SITE"))) S Y="@46";31R~;S SUB=X;I $D(SUB) S PRCX=$O(^PRC(411,SUB,1,0)) S:$G(PRCX)]"" PRCY=$P($G(^PRC(411,SUB,1,PRCX,0)),U) K PRCX;@46; "KRN",.402,2663,"DR",1,442,3) S PRCHCDNO=$P($G(^PRC(442,DA,23)),U,8);S PRCHNN=0 F PRCHII=1:1 S PRCHNN=$O(^PRC(440.5,"C",DUZ,PRCHNN)) Q:'PRCHNN S PRCHCDF=$P(^PRC(440.5,PRCHNN,0),U);S PRCHCDFT="" I PRCHII=2 S PRCHCDFT=PRCHCDF;D LOOK^PRCSPC; "KRN",.402,2663,"DR",1,442,4) I (X="")!(X["^") S ERRFLG=2,Y=0;I $G(PRCHXXX)="" S ERRFLG=2,Y=0;46////^S X=$G(PRCHXXX);I PRCHCDNO'="",X'=PRCHCDNO W !,?5,"Please verify the accounting information for the new Purchase Card.",!; "KRN",.402,2663,"DR",1,442,5) I X]"" S PRCHP0=^PRC(440.5,X,0),PRCHFCP=$P(PRCHP0,U,2),PRCHCC=$P(PRCHP0,U,3),PRCHBOC1=$P(PRCHP0,U,4),PRCHDLOC=$P(PRCHP0,U,7),PRCHCD=$P(PRCHP0,U),PRCHCDNO=+X,PRCHHLDR=$P(PRCHP0,U,8);61////^S X=PRCHHLDR;55///^S X=PRCHCD;Q;Q;Q;Q; "KRN",.402,2663,"DR",1,442,6) .1//TODAY;I +X
250)!(PRCHSHP=0))) S Y="@99";13.2;13.4;13.3;@99;K PRCHDUZ;40;20; "KRN",.402,2663,"DR",2,442.01) S PRCHREC=DA;.01;K PRCSAVE;S PRCHINUM=DA,PRCHOLD=$P($G(^PRC(442,PRCHIEN,2,PRCHINUM,0)),U,2);1.5;I X=""&($L($P($G(^PRC(442,DA(1),2,DA,2)),U,3))=4) S PRCSAVE="G",Y="@101"; "KRN",.402,2663,"DR",2,442.01,1) I X=""&($L($P($G(^PRC(442,DA(1),2,DA,2)),U,3))=5) S PRCSAVE="S",Y="@101";I X=""&($G(PRCSAVE)="") D ^PRCHAAC4 I $D(PRCHANS) S PRCSAVE=PRCHANS;@101;I $G(PRCSAVE)="^" K PRCHANS,PRCSAVE S Y=0; "KRN",.402,2663,"DR",2,442.01,2) I X'="",$G(PRCHN("SFC"))'=2 S PRCHMAND=$P($G(^PRC(441,X,0)),U,8) I $G(PRCHMAND),PRCHMAND'=$P($G(^PRC(442,DA(1),1)),U) W !,"This item can only be purchased from "_$P($G(^PRC(440,PRCHMAND,0)),U) S Y=1.5;1; "KRN",.402,2663,"DR",2,442.01,3) I '$D(^PRC(442,DA(1),2,DA,1)) W $C(7),!,"Description is Required!!" S Y=1;S (PRCHQUAN,Z)="" I $D(^PRC(442,DA(1),1)) S Z=$S($D(^PRC(441,+$P(^PRC(442,DA(1),2,DA,0),U,5),2,+^PRC(442,DA(1),1),0)):^(0),1:""); "KRN",.402,2663,"DR",2,442.01,4) I Z'="" W:$P(Z,U,12)'="" !," Minimum Order Qty.: ",$P(Z,U,12) W:$P(Z,U,9) !," Maximum Order Qty.: ",$P(Z,U,9) W:$P(Z,U,11) !," Required Order Multiple: ",$P(Z,U,11) S PRCHQUAN=Z K Z; "KRN",.402,2663,"DR",2,442.01,5) 2//^S X=$S($P(PRCHQUAN,U,12)'="":$P(PRCHQUAN,U,12),$P(PRCHQUAN,U,11)'="":$P(PRCHQUAN,U,11),1:""); "KRN",.402,2663,"DR",2,442.01,6) I $P(PRCHQUAN,U,12)'="" I X<$P(PRCHQUAN,U,12) W !,"QUANTITY is less than the Minimum Order Quantity of ",$P(PRCHQUAN,U,12),$C(7) S Y=2; "KRN",.402,2663,"DR",2,442.01,7) I $P(PRCHQUAN,U,9)'="" I X>$P(PRCHQUAN,U,9) W !,"QUANTITY is more than the Maximum Order Quantity of ",$P(PRCHQUAN,U,9),$C(7) S Y=2; "KRN",.402,2663,"DR",2,442.01,8) I $P(PRCHQUAN,U,11)'="" I X#$P(PRCHQUAN,U,11)'=0 W !,"QUANTITY is not a Required Order Multiple value of ",$P(PRCHQUAN,U,11),$C(7) S Y=2;3;5;D TSTREQ1^PRCHNPO9;3.1;S DIE("NO^")="A";9.7;K DIE("NO^");9;8T~; "KRN",.402,2663,"DR",2,442.01,9) I $G(PRCSAVE)'="^" D EN10^PRCHNPO7;S PRCHFCP=+$P(^PRC(442,DA(1),0),U,3),PRCHN("COM")=$S($D(^PRC(441.2,+X,0)):$P(^(0),U,4),1:"") S:(PRCHN("COM")'=1)&($E($P($G(^PRC(420,PRCHSTN,1,PRCHFCP,0)),U,18),1,2)'=11) Y=4;4; "KRN",.402,2663,"DR",2,442.01,10) S PRCHIDA=+$P(^PRC(442,DA(1),2,DA,0),U,5);K PRCHBOCC;I PRCHN("SFC")=2 S ACCT=$$ACCT^PRCPUX1($E($$NSN^PRCPUX1(PRCHIDA),1,4)) S PRCHBOCC=$S(ACCT=1:2697,ACCT=2:2698,ACCT=3:2699,ACCT=6:2699,ACCT=8:2696,1:2699); "KRN",.402,2663,"DR",2,442.01,11) I '$G(PRCHBOCC) S Y="@87";S PRCHBOCC=$P($G(^PRCD(420.2,PRCHBOCC,0)),U);3.5////^S X=PRCHBOCC;S Y="@89";@87;3.5;@89;K PRCHBOCC,PRCHANS,PRCSAVE; "KRN",.402,2664,-1) 0^4 "KRN",.402,2664,0) PRCH DELIVERY ORDER^3130918.1609^^442^^^3140310 "KRN",.402,2664,"DIAB",3,0,442,6) PCDO VENDOR;REQ "KRN",.402,2664,"DIAB",4,0,442,3) SUBSTATION;REQ "KRN",.402,2664,"DIAB",8,1,442.01,10) FEDERAL SUPPLY CLASSIFICATION;T "KRN",.402,2664,"DR",1,442) Q:'$D(PRC("SITE")) S (PRCHN("SVC"),PRCHN("CC"),PRCHN("SC"),PRCHN("INV"))="",PRCHN("SFC")=+$P(^PRC(442,DA,0),U,19),PRCHN("FOB")=$S($D(^(1)):$P(^(1),U,6),1:""),PRCHN(12)=$S($D(^PRC(442,DA,12)):^(12),1:""); "KRN",.402,2664,"DR",1,442,1) S PRCHNVF="",PRCHPONO=$P(^PRC(442,DA,0),U,1),PRCHSTN=$P(PRCHPONO,"-") S PRCHIEN=DA;S PRCX=$O(^PRC(411,PRC("SITE"),1,0)) S:$G(PRCX)]"" PRCY=$P($G(^PRC(411,PRC("SITE"),1,PRCX,0)),U) K PRCX;D EN2^PRCHNPO6; "KRN",.402,2664,"DR",1,442,2) S PRCHDUZ=$P(^VA(200,DUZ,0),U,1);S PRCHN("MP")=$S($D(^PRCD(442.5,+$P(^PRC(442,DA,0),U,2),0)):$P(^(0),U,3),1:""),PRCHN("INV")=$S(PRCHN("MP")=2:"FISCAL",PRCHN("MP")=12:"",PRCHN("INV")'="":PRCHN("INV"),1:"VA FSC");48///^S X="D"; "KRN",.402,2664,"DR",1,442,3) I '$D(^PRC(411,"UP",PRC("SITE"))) S Y=.1;S OSUB=$P($G(^PRC(442,DA,23)),U,7);I $D(^PRCS(410,+$P(^PRC(442,DA,0),"^",12),0)) S X=$P($G(^(0)),U,10) I +X=OSUB W !,"SUBSTATION: ",$P(^PRC(411,$P(^PRC(442,DA,23),U,7),0),U) S Y=.1;31R~; "KRN",.402,2664,"DR",1,442,4) S SUB=X;I $D(SUB) S PRCX=$O(^PRC(411,SUB,1,0)) S:$G(PRCX)]"" PRCY=$P($G(^PRC(411,SUB,1,PRCX,0)),U) K PRCX;Q;Q;Q;Q;Q;.1//TODAY;.02//^S X="INVOICE/RECEIVING REPORT"; "KRN",.402,2664,"DR",1,442,5) S PRCHN("MP")=$S($D(^PRCD(442.5,+X,0)):$P(^(0),U,3),1:""),PRCHN("INV")=$S(PRCHN("MP")=2:"FISCAL",PRCHN("MP")=12:"",PRCHN("INV")]"":PRCHN("INV"),1:"VA FSC");S PRCHCTPO=$S(PRCHN("MP")=2:"Y",1:"N"); "KRN",.402,2664,"DR",1,442,6) .08//^S X=$S(PRCHN("MP")=2:"Y",PRCHN("MP")=12:"Y",1:"N");.04//^S X=PRCHN("INV");53R~;S PRCHVEN=+X;5////^S X=PRCHVEN;8///^S X=6;K DIC("DR");@1;1;S PRC("CP")=X;I $$EN^PRCHNPOB(PRC("SITE"),PRC("CP")) S ERRFLG=99,Y=0; "KRN",.402,2664,"DR",1,442,7) S PRCHN("SFC")=$P(^PRC(442,DA,0),U,19);@2;I $G(PRC("BBFY"))="" S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),$P(^PRC(442,DA,0),U,3));26///^S X=PRC("BBFY");D EN2^PRCHNPO3;2//^S X=PRCHN("CC");@88; "KRN",.402,2664,"DR",1,442,8) S:PRCHN("MP")=2 Y="@3" I $D(^PRC(442,DA,1)),$P(^(1),U,18)]"" S Y="@3";@3;S:PRCHN("MP")=4 Y=5.3; "KRN",.402,2664,"DR",1,442,9) I '$P(^PRC(442,DA,0),U,19)&(PRCHN("MP")'=2) W !,"Enter the word 'PATIENT' in the 'DELIVERY LOCATION' field for a direct delivery",!,"to a patient.";5.6; "KRN",.402,2664,"DR",1,442,10) I X="PATIENT",$P(^PRC(442,DA,0),U,19) I $P(^(0),U,19)!(PRCHN("MP")=2) W *7,!," PATIENT DELIVERY not valid for this type of order!" S Y=5.6;5.4//^S X=$G(PRCY); "KRN",.402,2664,"DR",1,442,11) I $P(^PRC(442,DA,1),U,12)'="" W *7,!,"Delete the Direct Delivery patient name if you wish the 'Ship to' address",!,"to print on the P.O.",!;6.4//DESTINATION;S PRCHN("FOB")=X;Q;Q;Q;Q;Q;7//TODAY+10;8.2//^S X="N/A";13;S PRCHSHP=+X; "KRN",.402,2664,"DR",1,442,12) S:X']"" Y="@99";I $P(^PRC(442,DA,0),U,19)'=2 S Y="@98";S PRCHSBOC=$P($G(^PRCD(420.2,2299,0)),U);13.05////^S X=PRCHSBOC;S Y="@100";@98;13.05;@100;I '(PRCHN("FOB")="O"&((PRCHSHP>250)!(PRCHSHP=0))) S Y="@99";13.2;13.4;13.3;@99; "KRN",.402,2664,"DR",1,442,13) 16////^S X=DUZ;K PRCHDUZ;40;20; "KRN",.402,2664,"DR",2,442.01) S PRCHREC=DA;.01;K PRCSAVE;S PRCHINUM=DA,PRCHOLD=$P($G(^PRC(442,PRCHIEN,2,PRCHINUM,0)),U,2);1.5;I X=""&($L($P($G(^PRC(442,DA(1),2,DA,2)),U,3))=4) S PRCSAVE="G",Y="@101"; "KRN",.402,2664,"DR",2,442.01,1) I X=""&($L($P($G(^PRC(442,DA(1),2,DA,2)),U,3))=5) S PRCSAVE="S",Y="@101";I X=""&($G(PRCSAVE)="") D ^PRCHAAC4 I $D(PRCHANS) S PRCSAVE=PRCHANS;@101;I $G(PRCSAVE)="^" K PRCHANS,PRCSAVE S Y=0; "KRN",.402,2664,"DR",2,442.01,2) I X'="",$P($G(^PRC(441,X,2,PRCHVEN,0)),U,3)="",$G(PRCSAVE)="" W !,"This is not a contract item." S Y=1.5; "KRN",.402,2664,"DR",2,442.01,3) I X'="" S PRCHMAND=$P($G(^PRC(441,X,0)),U,8) I $G(PRCHMAND),PRCHMAND'=$P($G(^PRC(442,DA(1),1)),U) W !,"This item can only be purchased from "_$P($G(^PRC(440,PRCHMAND,0)),U) S Y=1.5;1; "KRN",.402,2664,"DR",2,442.01,4) I '$D(^PRC(442,DA(1),2,DA,1)) W $C(7),!,"Description is Required!!" S Y=1;S (PRCHQUAN,Z)="" I $D(^PRC(442,DA(1),1)) S Z=$S($D(^PRC(441,+$P(^PRC(442,DA(1),2,DA,0),U,5),2,+^PRC(442,DA(1),1),0)):^(0),1:""); "KRN",.402,2664,"DR",2,442.01,5) I Z'="" W:$P(Z,U,12)'="" !," Minimum Order Qty.: ",$P(Z,U,12) W:$P(Z,U,9) !," Maximum Order Qty.: ",$P(Z,U,9) W:$P(Z,U,11) !," Required Order Multiple: ",$P(Z,U,11) S PRCHQUAN=Z K Z; "KRN",.402,2664,"DR",2,442.01,6) 2//^S X=$S($P(PRCHQUAN,U,12)'="":$P(PRCHQUAN,U,12),$P(PRCHQUAN,U,11)'="":$P(PRCHQUAN,U,11),1:"");S PRCHTOT=0 I X$P(PRCHQUAN,U,9) W !,"QUANTITY is more than the Maximum Order Quantity of ",$P(PRCHQUAN,U,9),$C(7) S Y=2; "KRN",.402,2664,"DR",2,442.01,9) I $P(PRCHQUAN,U,11)'="" I X#$P(PRCHQUAN,U,11)'=0 W !,"QUANTITY is not a Required Order Multiple value of ",$P(PRCHQUAN,U,11),$C(7) S Y=2;3;5;I $D(^PRC(442,DA(1),1)),$P(^(1),U,20)="Y" S Y="@6";D TSTREQ1^PRCHNPO9;3.1; "KRN",.402,2664,"DR",2,442.01,10) S DIE("NO^")="A";9.7;K DIE("NO^");9;9.5;@6;S:PRCHN("MP")=2 Y=4;8T~;I $G(PRCSAVE)'="^" D EN10^PRCHNPO7; "KRN",.402,2664,"DR",2,442.01,11) S PRCHFCP=+$P(^PRC(442,DA(1),0),U,3),PRCHN("COM")=$S($D(^PRC(441.2,+X,0)):$P(^(0),U,4),1:"") S:$E($P($G(^PRC(420,PRCHSTN,1,PRCHFCP,0)),U,18),1,2)=11 Y=41 S:(PRCHN("COM")'=1)&($E($P($G(^(0)),U,18),1,2)'=11) Y=4;9.3; "KRN",.402,2664,"DR",2,442.01,12) D TSTREQ2^PRCHNPO9;40;S Y=4;41//^S Z=$S($D(^PRC(441,+$P(^PRC(442,DA(1),2,DA,0),U,5),3)):^(3),1:""),X=$P(Z,U,7);4;S PRCHIDA=+$P(^PRC(442,DA(1),2,DA,0),U,5);K PRCHBOCC; "KRN",.402,2664,"DR",2,442.01,13) S:PRCHN("SFC")=2 ACCT=$$ACCT^PRCPUX1($E($$NSN^PRCPUX1(PRCHIDA),1,4)),PRCHBOCC=$P($G(^PRCD(420.2,$S(ACCT=1:2697,ACCT=2:2698,ACCT=3:2699,ACCT=6:2699,ACCT=8:2696,1:2699),0)),U);I $G(PRCHBOCC) S Y="@87";3.5//^S X=$G(PRCHBOCC); "KRN",.402,2664,"DR",2,442.01,14) S Y="@89";@87;3.5////^S X=PRCHBOCC;S Y="@89";@87;3.5;@89;K PRCHBOCC,PRCHANS,PRCSAVE;S:'$D(PRCHEDI) Y="@5";36.3;36.6;@5; "KRN",.402,2673,-1) 0^3 "KRN",.402,2673,0) PRCH PC DIRECT DELIVERY^3130918.162^^442^^^3130918 "KRN",.402,2673,"DIAB",3,0,442,3) SUBSTATION;REQ "KRN",.402,2673,"DIAB",6,0,442,8) PCDO VENDOR;REQ "KRN",.402,2673,"DIAB",7,1,442.01,9) FEDERAL SUPPLY CLASSIFICATION;T "KRN",.402,2673,"DR",1,442) Q:'$D(PRC("SITE"));S (PRCHN("SVC"),PRCHN("CC"),PRCHN("SC"),PRCHN("INV"))="",PRCHN("SFC")=+$P(^PRC(442,DA,0),U,19),PRCHN("FOB")=$S($D(^(1)):$P(^(1),U,6),1:""),PRCHN(12)=$S($D(^PRC(442,DA,12)):^(12),1:""); "KRN",.402,2673,"DR",1,442,1) S PRCHNVF="",PRCHPONO=$P(^PRC(442,DA,0),U,1),PRCHSTN=$P(PRCHPONO,"-") S PRCHIEN=DA;S PRCX=$O(^PRC(411,PRC("SITE"),1,0)) S:$G(PRCX)]"" PRCY=$P($G(^PRC(411,PRC("SITE"),1,PRCX,0)),U) K PRCX;D EN2^PRCHNPO6; "KRN",.402,2673,"DR",1,442,2) S PRCHDUZ=$P(^VA(200,DUZ,0),U,1);16////^S X=DUZ;56////^S X=DUZ;.02///^S X=25;48///^S X="P";63///^S X=1;S X=$P($G(^PRC(442,DA,1)),U) I X>0,$P($G(^PRC(440,X,3)),U,2)="Y" S PRCHEDI="";I '$D(^PRC(411,"UP",PRC("SITE"))) S Y=.1; "KRN",.402,2673,"DR",1,442,3) S OSUB=$P($G(^PRC(442,DA,23)),U,7);I $D(^PRCS(410,+$P(^PRC(442,DA,0),"^",12),0)) S X=$P($G(^(0)),U,10) I +X=OSUB W !,"SUBSTATION: ",$P(^PRC(411,$P(^PRC(442,DA,23),U,7),0),U) S Y=.1;31R~; "KRN",.402,2673,"DR",1,442,4) I $D(^PRCS(410,+$P(^PRC(442,DA,0),"^",12),0)) I X'=OSUB W !,?5,"Sub-station cannot be changed because the attached 2237",!,?5,"would then have a different sub-station.",! S $P(^PRC(442,DA,23),U,7)=OSUB S Y=31; "KRN",.402,2673,"DR",1,442,5) S PRCX=$O(^PRC(411,X,1,0)) S:$G(PRCX)]"" PRCY=$P($G(^PRC(411,X,1,PRCX,0)),U) K PRCX;Q;Q;Q;.1//TODAY;S PRCHN("MP")=$S($D(^PRCD(442.5,+X,0)):$P(^(0),U,3),1:""),PRCHN("INV")=$S(PRCHN("INV")]"":PRCHN("INV"),1:"VA FSC"); "KRN",.402,2673,"DR",1,442,6) S PRCHCDNO=$P($G(^PRC(442,DA,23)),U,8);D LOOK^PRCSPC;I (X="")!(X["^") S ERRFLG=3,Y=0;I $G(PRCHXXX)="" S ERRFLG=3,Y=0;46////^S X=$G(PRCHXXX); "KRN",.402,2673,"DR",1,442,7) I PRCHCDNO'="",X'=PRCHCDNO W !,?5,"Please verify the accounting information for the new purchase card.",!; "KRN",.402,2673,"DR",1,442,8) I X]"" S PRCHP0=^PRC(440.5,X,0),PRCHFCP=$P(PRCHP0,U,2),PRCHCC=$P(PRCHP0,U,3),PRCHBOC1=$P(PRCHP0,U,4),PRCHCD=$P(PRCHP0,U),PRCHCDNO=+X,PRCHHLDR=$P(PRCHP0,U,8);55///^S X=PRCHCD;.08//^S X="N";.04//^S X=PRCHN("INV");@33;53R~; "KRN",.402,2673,"DR",1,442,9) I $P($G(^PRC(440,($P(^PRC(442,D0,23),U,14)),2)),U,11)'="Y" W !,?5,"This vendor is not a guarenteed delivery vendor." S $P(^PRC(442,DA,23),U,14)="" K X S Y="@33"; "KRN",.402,2673,"DR",1,442,10) S PRCHOV3=$G(^PRC(440,+^PRC(442,D0,1),3)) S:$P(PRCHOV3,"^",12)="P" Y="@20";I $G(PRCFLAG)=1 S $P(^PRC(442,DA,23),U,14)="" K X S Y=53;S PRCHVEN=+X;5////^S X=PRCHVEN;@20;18.6//^S X="N";I X="N" S Y="@10";18.7;@10;8//^S X=PRCHN("SC"); "KRN",.402,2673,"DR",1,442,11) I "46910"'[X K:0 DIC("DR") D ^PRCHNPO3 S Y="@1";.25;D ^PRCHNPO3;@1;1//^S X=PRCHFCP;S PRC("CP")=X;I $$EN^PRCHNPOB(PRC("SITE"),PRC("CP")) S ERRFLG=99,Y=0; "KRN",.402,2673,"DR",1,442,12) I $D(^PRCS(410,+$P(^PRC(442,DA,0),"^",12),0)) S X=$P($P(^(0),U,1),"-",4) I +X=+$P(^PRC(442,DA,0),U,3) W !,"FCP: ",$P(^(0),U,3) S Y="@2";S X=PRCHFCP; "KRN",.402,2673,"DR",1,442,13) S PRCHN("SFC")=$P(^PRC(442,DA,0),U,19) I PRCHN("SFC")'="" W !,"You cannot use a special control point for this type of order." S Y="@1";S PRC("CP")=$P(^PRC(442,DA,0),U,3);@2; "KRN",.402,2673,"DR",1,442,14) I $G(PRC("BBFY"))="" S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),$P(^PRC(442,DA,0),U,3));26///^S X=PRC("BBFY");D EN2^PRCHNPO3;2//^S X=PRCHCC;@88;5.2//^S X=PRCHN("SVC");I $D(^PRC(442,DA,1)),$P(^(1),U,18)]"" S Y="@3"; "KRN",.402,2673,"DR",1,442,15) .3//^S X="E";@3;52;5.3;5.6////^S X="PATIENT";5.4;6.2;6.4;S PRCHN("FOB")=X;Q;Q;Q;7//TODAY+10;8.2//^S X="N/A";8.3;13;S PRCHSHP=+X;I $P(^PRC(442,DA,0),U,19)'=2 S Y="@98";S PRCHSBOC=$P($G(^PRCD(420.2,2299,0)),U);13.05////^S X=PRCHSBOC; "KRN",.402,2673,"DR",1,442,16) S Y="@100";@98;13.05;@100;S:'$D(PRCHSHP) PRCHSHP=$P(^PRC(442,DA,0),U,13) I '(PRCHN("FOB")="O"&((PRCHSHP>250)!(PRCHSHP=0))) S Y="@99";13.2;13.4;13.3;@99;97//^S X="A";16//^S X=$S($D(PRCHDUZ):PRCHDUZ,1:""); "KRN",.402,2673,"DR",1,442,17) S PRCHDUZ1=X I $P(^PRC(442,DA,0),U,2)=25,'$D(^PRC(440.5,"H",X)) W *7,!,"This user is not a purchase card user." S Y=16;61////^S X=PRCHDUZ1;@25;K PRCHDUZ,PRCHDUZ1;40;24;20;K PRCHANS,PRCHTPO,PRCHSEEN,PRCHMORE,PRCHQTY,PRCSAVE; "KRN",.402,2673,"DR",2,442.01) S PRCHREC=DA,PRCHQUAN="",Z="",PRCHTOT=0;.01;K PRCSAVE;S PRCHINUM=DA,PRCHOLD=$P($G(^PRC(442,PRCHIEN,2,PRCHINUM,0)),U,2);1.5;I X=""&($L($P($G(^PRC(442,DA(1),2,DA,2)),U,3))=4) S PRCSAVE="G",Y="@101"; "KRN",.402,2673,"DR",2,442.01,1) I X=""&($L($P($G(^PRC(442,DA(1),2,DA,2)),U,3))=5) S PRCSAVE="S",Y="@101";I X=""&($G(PRCSAVE)="") D ^PRCHAAC4 I $D(PRCHANS) S PRCSAVE=PRCHANS;@101;I $G(PRCSAVE)="^" K PRCHANS,PRCSAVE S Y=0;1; "KRN",.402,2673,"DR",2,442.01,2) I '$D(^PRC(442,DA(1),2,DA,1)) W $C(7),!,"Description is Required!!" S Y=1;I $D(^PRC(442,DA(1),1)) S Z=$S($D(^PRC(441,+$P(^PRC(442,DA(1),2,DA,0),U,5),2,+^PRC(442,DA(1),1),0)):^(0),1:""); "KRN",.402,2673,"DR",2,442.01,3) I Z'="" W:$P(Z,U,12)'="" !," Minimum Order Qty.: ",$P(Z,U,12) W:$P(Z,U,9) !," Maximum Order Qty.: ",$P(Z,U,9) W:$P(Z,U,11) !," Required Order Multiple: ",$P(Z,U,11) S PRCHQUAN=Z K Z; "KRN",.402,2673,"DR",2,442.01,4) 2//^S X=$S($P(PRCHQUAN,U,12)'="":$P(PRCHQUAN,U,12),$P(PRCHQUAN,U,11)'="":$P(PRCHQUAN,U,11),1:"");I XX W !!!!!,$C(7),"****Delivery schedule total for this item (",PRCHTOT,") EXCEEDS order quantity (",X,").",!,"Edit delivery schedule(s) now." S PRCHFLG=1,PRCHQTY=X S Y="@16";@44; "KRN",.402,2673,"DR",2,442.01,6) I $P(PRCHQUAN,U,12)'="" I X<$P(PRCHQUAN,U,12) W !,"QUANTITY is less than the Minimum Order Quantity of ",$P(PRCHQUAN,U,12),$C(7) S Y=2; "KRN",.402,2673,"DR",2,442.01,7) I $P(PRCHQUAN,U,9)'="" I X>$P(PRCHQUAN,U,9) W !,"QUANTITY is more than the Maximum Order Quantity of ",$P(PRCHQUAN,U,9),$C(7) S Y=2; "KRN",.402,2673,"DR",2,442.01,8) I $P(PRCHQUAN,U,11)'="" I X#$P(PRCHQUAN,U,11)'=0 W !,"QUANTITY is not a Required Order Multiple value of ",$P(PRCHQUAN,U,11),$C(7) S Y=2;3;5;I $D(^PRC(442,DA(1),1)),$P(^(1),U,20)="Y" S Y="@6";D TSTREQ1^PRCHNPO9;3.1;9.4;S:X']"" Y=9; "KRN",.402,2673,"DR",2,442.01,9) S DIE("NO^")="A";9.7;K DIE("NO^");9;9.5;@6;8T~;I $G(PRCSAVE)'="^" D EN10^PRCHNPO7; "KRN",.402,2673,"DR",2,442.01,10) S PRCHFCP=+$P(^PRC(442,DA(1),0),U,3),PRCHN("COM")=$S($D(^PRC(441.2,+X,0)):$P(^(0),U,4),1:"") S:$E($P($G(^PRC(420,PRCHSTN,1,PRCHFCP,0)),U,18),1,2)=11 Y=41 S:(PRCHN("COM")'=1)&($E($P($G(^(0)),U,18),1,2)'=11) Y=4;9.3; "KRN",.402,2673,"DR",2,442.01,11) D TSTREQ2^PRCHNPO9;40;41//^S Z=$S($D(^PRC(441,+$P(^PRC(442,DA(1),2,DA,0),U,5),3)):^(3),1:""),X=$P(Z,U,7);42;4;@87;36.3;36.6;@5; "KRN",.402,2673,"DR",2,442.01,12) S PRCHTOT=0,PRCHSCN="" F I=0:0 S PRCHSCN=$O(^PRC(442.8,"B",PRCHPONO,PRCHSCN)) Q:PRCHSCN="" I $P(^PRC(442.8,PRCHSCN,0),U,2)=DA S PRCHTOT=PRCHTOT+$P(^(0),U,5);S PRCHQTY=$P(^PRC(442,DA(1),2,DA,0),U,2); "KRN",.402,2673,"DR",2,442.01,13) I PRCHTOT>PRCHQTY S PRCHDA1=DA(1),PRCHDA=DA,PRCHLINO=$P(^PRC(442,DA(1),2,PRCHREC,0),U) W !,"Line Item # = ",PRCHLINO,!,"Orig. Quantity Ordered: "_$P(^PRC(442,DA(1),2,PRCHREC,0),U,2),! S Y="@555"; "KRN",.402,2673,"DR",2,442.01,14) W !!,"Enter/Edit Delivery Schedule for this Item? NO// " R X:DTIME S:'$T X="^" S:X="" X="N" S:X["?" Y="@5" S:"Yy?"'[$E(X) Y="@56" W " "_$S("Yy"[$E(X):"(YES)","Nn"[$E(X):"(NO)",1:"");@16; "KRN",.402,2673,"DR",2,442.01,15) S PRCHDA1=DA(1),PRCHDA=DA,PRCHLINO=$P(^PRC(442,DA(1),2,PRCHREC,0),U) W !,"Line Item #=",PRCHLINO,!,"Orig. Quantity Ordered: "_$P(^PRC(442,DA(1),2,PRCHREC,0),U,2),!; "KRN",.402,2673,"DR",2,442.01,16) I PRCHTOT=PRCHQTY W !,"Delivery schedule quantity of ",PRCHTOT," equals order quantity of ",PRCHQTY,".",!,"You may edit delivery schedule(s), but cannot add a new schedule.",!;@555; "KRN",.402,2673,"DR",2,442.01,17) I PRCHTOT>PRCHQTY W !,"Delivery schedule quantity of ",PRCHTOT," EXCEEDS order quantity of ",PRCHQTY,". You must edit",!,"one or more schedules so that the total equals no more than ",PRCHQTY,".",! S Y="@55"; "KRN",.402,2673,"DR",2,442.01,18) S:$D(PRCHSEEN) Y="@55";S PRCHSEEN=1 W !!,"To delete a schedule, zero out the quantity to be delivered. To add a new",!,"delivery schedule do the following:",!!; "KRN",.402,2673,"DR",2,442.01,19) W "a. If there is no delivery schedule already in file answer 'Yes' when asked if you are adding a new delivery schedule."; "KRN",.402,2673,"DR",2,442.01,20) W !,"b. If there is only one delivery schedule already in the file you will see 'OK? YES//' answer 'No' and then answer 'Yes' when asked if you are adding a new delivery schedule."; "KRN",.402,2673,"DR",2,442.01,21) W !,"c. If there is more than one delivery schedule in the file, hit key at 'CHOOSE' prompt and answer 'Yes' when asked if you are adding a new delivery schedule.";@55; "KRN",.402,2673,"DR",2,442.01,22) S:$G(PRCHDA) PRCHINUM=PRCHDA S PRCHQTY=$P(^PRC(442,PRCHIEN,2,PRCHINUM,0),U,2); "KRN",.402,2673,"DR",2,442.01,23) I $G(PRCHFLG),PRCHTOT>PRCHQTY W !!,"Delivery schedule total of ",PRCHTOT," EXCEEDS ordered quantity.",!,"of ",PRCHQTY,". Adjust delivery schedule(s)." S Y="@16"; "KRN",.402,2673,"DR",2,442.01,24) I $G(PRCHFLG) S PRCHFLG=0 W !!!!,"****Returning to Item Multiple edit session." S Y="@44";I PRCHTOT>PRCHQTY S Y="@555"; "KRN",.402,2673,"DR",2,442.01,25) W !!,"Enter/Edit Another Delivery Schedule for this Item? NO// " R X:DTIME S:'$T X="^" S:X="" X="N" S:X["?" Y="@5" S:"Yy?"[$E(X) Y="@16";@56;K PRCHTOT,PRCHSCN;3.5; "KRN",.402,2673,"DR",2,442.12) .01; "KRN",.402,2673,"DR",2,442.15) .01; "KRN",.402,2931,-1) 0^1 "KRN",.402,2931,0) PRCHSIMP^3130918.1604^@^442^^@^3130918 "KRN",.402,2931,"DIAB",2,0,442,7) PCDO VENDOR;REQ "KRN",.402,2931,"DIAB",2,0,442,8) FREE TEXT VENDOR;REQ "KRN",.402,2931,"DIAB",7,0,442,2) SUBSTATION;REQ "KRN",.402,2931,"DIAB",10,0,442,9) PURCHASE COST;REQ "KRN",.402,2931,"DR",1,442) Q:'$D(PRC("SITE")) S (PRCHN("SVC"),PRCHN("CC"),PRCHN("SC"),PRCHN("INV"))="",PRCHN("SFC")=+$P(^PRC(442,DA,0),U,19),PRCHN("FOB")=$S($D(^(1)):$P(^(1),U,6),1:""),PRCHN(12)=$S($D(^PRC(442,DA,12)):^(12),1:""); "KRN",.402,2931,"DR",1,442,1) S PRCHPONO=$P(^PRC(442,DA,0),U,1),PRCHSTN=$P(PRCHPONO,"-") S PRCHIEN=DA;S PRCX=$O(^PRC(411,PRC("SITE"),1,0)) S:$G(PRCX)]"" PRCY=$P($G(^PRC(411,PRC("SITE"),1,PRCX,0)),U) K PRCX;S PRCHDUZ=$P(^VA(200,DUZ,0),U,1);16////^S X=DUZ; "KRN",.402,2931,"DR",1,442,2) 56////^S X=DUZ;.02///^S X=25;48///^S X="S";63///^S X=1;54///^S X="N";I '$D(^PRC(411,"UP",PRC("SITE"))) S Y="@46";31R~;S SUB=X;I $D(SUB) S PRCX=$O(^PRC(411,SUB,1,0)) S:$G(PRCX)]"" PRCY=$P($G(^PRC(411,SUB,1,PRCX,0)),U) K PRCX;@46; "KRN",.402,2931,"DR",1,442,3) S PRCHCDNO=$P($G(^PRC(442,DA,23)),U,8);S PRCHNN=0 F PRCHII=1:1 S PRCHNN=$O(^PRC(440.5,"C",DUZ,PRCHNN)) Q:'PRCHNN S PRCHCDF=$P(^PRC(440.5,PRCHNN,0),U);S PRCHCDFT="" I PRCHII=2 S PRCHCDFT=PRCHCDF;D LOOK^PRCSPC; "KRN",.402,2931,"DR",1,442,4) I (X="")!(X["^") S ERRFLG=1,Y=0;I $G(PRCHXXX)="" S ERRFLG=1,Y=0;46////^S X=$G(PRCHXXX);I PRCHCDNO'="",X'=PRCHCDNO W !,?5,"Please verify the accounting information for the new Purchase Card.",!; "KRN",.402,2931,"DR",1,442,5) I X]"" S PRCHP0=^PRC(440.5,X,0),PRCHFCP=$P(PRCHP0,U,2),PRCHCC=$P(PRCHP0,U,3),PRCHBOC1=$P(PRCHP0,U,4),PRCHDLOC=$P(PRCHP0,U,7),PRCHCD=$P(PRCHP0,U),PRCHCDNO=+X,PRCHHLDR=$P(PRCHP0,U,8);61////^S X=PRCHHLDR;55///^S X=PRCHCD;Q;Q;Q;Q; "KRN",.402,2931,"DR",1,442,6) .1//TODAY;I +X
3000 W !,$C(7),"COST CANNOT EXCEED $3000.00 - YOU MUST USE DETAILED PURCHASE CARD!!" S Y="@3";5.4///^S X="SIMPLIFIED";S $P(^PRC(442,DA,0),"^",15)=PRCHTOT; "MBREQ") 0 "ORD",7,.402) .402;7;;;EDEOUT^DIFROMSO(.402,DA,"",XPDA);FPRE^DIFROMSI(.402,"",XPDA);EPRE^DIFROMSI(.402,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.402,DA,"",XPDA);DEL^DIFROMSK(.402,"",%) "ORD",7,.402,0) INPUT 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) 184^3140311 "PKG",455,22,1,"PAH",1,1,0) ^^6^6^3140311 "PKG",455,22,1,"PAH",1,1,1,0) "PKG",455,22,1,"PAH",1,1,2,0) 1. Purchase Card and Delivery orders reaching 2237 max on backend filing "PKG",455,22,1,"PAH",1,1,3,0) "PKG",455,22,1,"PAH",1,1,4,0) 2. Purchase Card accrual issue from one quarter to next with Carry Forward "PKG",455,22,1,"PAH",1,1,5,0) "PKG",455,22,1,"PAH",1,1,6,0) 3. Documentation error in Control Point Official's Manual "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") YES "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") 4 "RTN","PRCH1A3") 0^2^B27339623^B22668884 "RTN","PRCH1A3",1,0) PRCH1A3 ;WISC/PLT-PRCH1A continued ;9/8/98 11:10 "RTN","PRCH1A3",2,0) V ;;5.1;IFCAP;**184**;Oct 20, 2000;Build 8 "RTN","PRCH1A3",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCH1A3",4,0) ; "RTN","PRCH1A3",5,0) ;PRC*5.1*184 If Final Charge edited from 'Y' to 'N' add logic to "RTN","PRCH1A3",6,0) ; flip the attached 2237s from Running Balance Status "RTN","PRCH1A3",7,0) ; 'O' back to 'A' to insure they are carried forward "RTN","PRCH1A3",8,0) ; to next fiscal quarter. "RTN","PRCH1A3",9,0) ; "RTN","PRCH1A3",10,0) QUIT ;invalid entry "RTN","PRCH1A3",11,0) ; "RTN","PRCH1A3",12,0) RC ;entry point - prch1d "RTN","PRCH1A3",13,0) ;if the order is Simplified or Detailed but receiving is not required, "RTN","PRCH1A3",14,0) ;confirm receipt with the user; otherwise check file #442, "RTN","PRCH1A3",15,0) ;node 11 before asking the user any questions. "RTN","PRCH1A3",16,0) ; "RTN","PRCH1A3",17,0) N PRCFOLD "RTN","PRCH1A3",18,0) S PRCE=^PRC(442,PRCRI(442),0),PRCCP=$P($G(^(23)),"^",16),PRCR=$P($G(^(23)),"^",15) "RTN","PRCH1A3",19,0) I PRCR="N",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="S" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),43) I $G(X)=-1 D EXIT QUIT "RTN","PRCH1A3",20,0) I PRCR="N",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="P" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),43) I $G(X)=-1 D EXIT QUIT "RTN","PRCH1A3",21,0) ; "RTN","PRCH1A3",22,0) I PRCR="Y",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="P" D I $G(X)=-1 D EXIT QUIT "RTN","PRCH1A3",23,0) . D CHKREC I $P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y" Q "RTN","PRCH1A3",24,0) . D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N") I $G(X)=-1 D EXIT QUIT "RTN","PRCH1A3",25,0) ; "RTN","PRCH1A3",26,0) ;See if the order was entered by a PA with MOP=25 and confirm receipt. "RTN","PRCH1A3",27,0) I PRCR="Y",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="" D I $G(X)=-1 D EXIT QUIT "RTN","PRCH1A3",28,0) . D CHKREC I $P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y" Q "RTN","PRCH1A3",29,0) . D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N") "RTN","PRCH1A3",30,0) ; "RTN","PRCH1A3",31,0) I PRCR="N",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="" D I $G(X)=-1 D EXIT QUIT "RTN","PRCH1A3",32,0) . D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),43) "RTN","PRCH1A3",33,0) ; "RTN","PRCH1A3",34,0) ;Check old orders where receiving required was not specified by the PA. "RTN","PRCH1A3",35,0) I PRCR="",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="" S PRCR="Y" D I $G(X)=-1 D EXIT QUIT "RTN","PRCH1A3",36,0) . D CHKREC I $P($G(^PRCH(440.6,PRCRI(440.6),1)),"^",3)="Y" Q "RTN","PRCH1A3",37,0) . D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////N") "RTN","PRCH1A3",38,0) ; "RTN","PRCH1A3",39,0) ;Check PC Direct Delivery Orders. These orders are not received at the "RTN","PRCH1A3",40,0) ;station. "RTN","PRCH1A3",41,0) I PRCR="",$P($G(^PRC(442,PRCRI(442),23)),"^",11)="P" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////Y") I $G(X)=-1 D EXIT QUIT "RTN","PRCH1A3",42,0) ; "RTN","PRCH1A3",43,0) S PRCFOLD=^PRCH(440.6,PRCRI(440.6),1) "RTN","PRCH1A3",44,0) W !,"WARNING: If a credit or additional charge is expected against this order number" "RTN","PRCH1A3",45,0) W !,"do NOT respond YES." "RTN","PRCH1A3",46,0) D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"44;15////R;45////"_DUZ) I $G(X)=-1 D EXIT QUIT "RTN","PRCH1A3",47,0) D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"46///T;41////"_PRCRI(442)_";42////"_PRCR) "RTN","PRCH1A3",48,0) S PRCRI(410)=$P(^PRC(442,PRCRI(442),0),"^",12),PRCF=$P($G(^(7)),"^",2) "RTN","PRCH1A3",49,0) I PRCRI(410) S PRCCOA=$P($G(^PRCS(410,PRCRI(410),4)),"^",8) "RTN","PRCH1A3",50,0) I '$G(PRCEDRM) D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"18////"_PRCCOA_";19////"_PRCF) "RTN","PRCH1A3",51,0) S PRCF=^PRCH(440.6,PRCRI(440.6),1),PRCST=$S($P(PRCF,U,2)]"":$P(PRCF,U,2),1:"N")_$S($P(PRCF,U,3)]"":$P(PRCF,U,3),1:"N")_$S($P(PRCF,U,4)]"":$P(PRCF,U,4),1:"N") "RTN","PRCH1A3",52,0) I $E(PRCST)="N" S PRCSTC=$E("NC",$E(PRCST,2)="Y"+1)_$E(PRCST,3) "RTN","PRCH1A3",53,0) E S PRCSTC=$S($D(^PRC(442,PRCRI(442),2,"C"))&$D(^PRC(442,PRCRI(442),11)):"P",'$D(^PRC(442,PRCRI(442),11)):"N",1:"C")_$E(PRCST,3) "RTN","PRCH1A3",54,0) S PRCST=$P($T(@PRCSTC),";",3,4),PRCST=$S($D(^PRC(442,PRCRI(442),6)):+$P(PRCST,";",2),1:+$P(PRCST,";")) "RTN","PRCH1A3",55,0) D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"58///T;.5///"_PRCST) "RTN","PRCH1A3",56,0) I $P(PRCF,"^",4)="N" D "RTN","PRCH1A3",57,0) . S PRCVAL="" D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"44Are you going to dispute this charge amount?//NO;S PRCVAL=X W:X?1""Y"".U !,""You must file a disputed claim form with Purchase Card Company.""") "RTN","PRCH1A3",58,0) . I PRCVAL?1"Y".U D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"15////D") "RTN","PRCH1A3",59,0) . I $P(PRCFOLD,"^",4)="Y" D ;PRC*5.1*184 Check for Final Charge edit from 'yes' to 'no' to flip RB status in file 410 linked 2237s "RTN","PRCH1A3",60,0) .. S PRCRI(410)=0 "RTN","PRCH1A3",61,0) .. F S PRCRI(410)=$O(^PRC(442,PRCRI(442),13,PRCRI(410))) QUIT:'PRCRI(410) D:PRCRI(410) ERS410^PRC0G(PRCRI(410)_"^A") "RTN","PRCH1A3",62,0) .. Q "RTN","PRCH1A3",63,0) . QUIT "RTN","PRCH1A3",64,0) I $P(PRCF,"^",4)="Y" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"15////R"),EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"44////N") "RTN","PRCH1A3",65,0) I $P(PRCF,"^",4)="Y",PRCRI(410) D "RTN","PRCH1A3",66,0) . N A,B "RTN","PRCH1A3",67,0) . S A=0,B=0 F S A=$O(^PRCH(440.6,"PO",PRCRI(442),A)) QUIT:'A S B=B+$P(^PRCH(440.6,A,0),"^",14) "RTN","PRCH1A3",68,0) . I B-PRCCOA D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"27////"_B) "RTN","PRCH1A3",69,0) . S PRCRI(410)=0 "RTN","PRCH1A3",70,0) . F S PRCRI(410)=$O(^PRC(442,PRCRI(442),13,PRCRI(410))) QUIT:'PRCRI(410) D:PRCRI(410) ERS410^PRC0G(PRCRI(410)_"^O") "RTN","PRCH1A3",71,0) . QUIT "RTN","PRCH1A3",72,0) D EDIT^PRC0B(.X,"442;^PRC(442,;"_PRCRI(442),"20") "RTN","PRCH1A3",73,0) S A=$$DDA4406^PRCH0A(PRCRI(440.6)),B=$$DDA442^PRCH0A(PRCRI(442)),$P(B,"^",17)="",PRCBOC=$P(B,"^",21),$P(B,"^",33)=$P(A,"^",33) "RTN","PRCH1A3",74,0) I '$G(PRCEDRM),A'=B D "RTN","PRCH1A3",75,0) . I $E(PRCB,13,15)>490 D EN^DDIOL("Enter ET-Document by FMS-ON LINE!") QUIT "RTN","PRCH1A3",76,0) . D EN^DDIOL("Generating ET-document to FMS...") "RTN","PRCH1A3",77,0) . D ET^PRCH8A(.X,PRCRI(440.6)_"^"_PRCRI(442)_"^1^"_PRCBOC,"") "RTN","PRCH1A3",78,0) . I X D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"17////"_$P(X,"^")) "RTN","PRCH1A3",79,0) . QUIT "RTN","PRCH1A3",80,0) EXIT D:$D(IOSTBM) SS(1,24),CS "RTN","PRCH1A3",81,0) K FINALDEL,FPARTIAL,PARTIAL "RTN","PRCH1A3",82,0) QUIT "RTN","PRCH1A3",83,0) ; "RTN","PRCH1A3",84,0) SS(IOTM,IOBM) ;screen size a-top, b=bottom margin "RTN","PRCH1A3",85,0) W @IOSTBM QUIT "RTN","PRCH1A3",86,0) ; "RTN","PRCH1A3",87,0) MC(DX,DY) ;move cursor dx=column #, dy=row number "RTN","PRCH1A3",88,0) S DX=DX-1,DY=DY-1 X IOXY QUIT "RTN","PRCH1A3",89,0) ; "RTN","PRCH1A3",90,0) CS W @IOF QUIT "RTN","PRCH1A3",91,0) ; "RTN","PRCH1A3",92,0) CHKREC ;Determine the receiving status of the order "RTN","PRCH1A3",93,0) S PARTIAL=+$P($G(^PRC(442,PRCRI(442),11,0)),"^",3) Q:$G(PARTIAL)=0 "RTN","PRCH1A3",94,0) S:PARTIAL>0 FPARTIAL=$G(^PRC(442,PRCRI(442),11,PARTIAL,0)) "RTN","PRCH1A3",95,0) S:FPARTIAL]"" FINALDEL=$P($G(FPARTIAL),"^",9) "RTN","PRCH1A3",96,0) I FINALDEL["F" D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"43////Y") "RTN","PRCH1A3",97,0) Q "RTN","PRCH1A3",98,0) ; "RTN","PRCH1A3",99,0) STATUS ;order status 1-pos:n,p,c for receiving, 2-pos:n,y for final payment "RTN","PRCH1A3",100,0) NN ;;39;44 "RTN","PRCH1A3",101,0) NY ;;24;29 "RTN","PRCH1A3",102,0) PN ;;46;47 "RTN","PRCH1A3",103,0) PY ;;32;34 "RTN","PRCH1A3",104,0) CN ;;48;49 "RTN","PRCH1A3",105,0) CY ;;50;51 "RTN","PRCH1A3",106,0) ; "RTN","PRCHNPO") 0^1^B62074705^B58254846 "RTN","PRCHNPO",1,0) PRCHNPO ;WISC/SC,ID/RSD/RHD/DGL/BGJ-ENTER NEW PURCHASE ORDER/REQUISITION ; 4/2/01 1:50pm "RTN","PRCHNPO",2,0) V ;;5.1;IFCAP;**7,11,79,108,123,184**;Oct 20, 2000;Build 8 "RTN","PRCHNPO",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCHNPO",4,0) ; "RTN","PRCHNPO",5,0) ;PRC*5.1*184 Added check for Purchase Card orders to insure there "RTN","PRCHNPO",6,0) ; are sufficient requisition sequence entries (>5) for "RTN","PRCHNPO",7,0) ; requisition created in file 410 for related FCP used "RTN","PRCHNPO",8,0) ; and control for Running Balance Report. "RTN","PRCHNPO",9,0) ; "RTN","PRCHNPO",10,0) S NOTCOMPL=0 ;Initialize for Incomplete Template. "RTN","PRCHNPO",11,0) D SWITCH^PRCHUTL K ERRFLG ; SET LOG/ISMS SWITCH "RTN","PRCHNPO",12,0) K PRCSIP ; Initialize Inventory point variable "RTN","PRCHNPO",13,0) I $S('$G(PRCHPO):1,'$D(PRC("SITE")):1,1:0) G Q "RTN","PRCHNPO",14,0) S DIE="^PRC(442,",DR="["_$S($D(PRCHNRQ):"PRCHNREQ",1:"PRCH2138")_"]",DIC("DR")="[PRCHVENDOR]" "RTN","PRCHNPO",15,0) I $G(PRCPROST)=1 S DR="[PRCH PROSTHETIC]" D ^DIE QUIT "RTN","PRCHNPO",16,0) I $G(PRCHPC)=1 S DR="[PRCHSIMP]" "RTN","PRCHNPO",17,0) I $G(PRCHPC)=2 S DR="[PRCH DETAILED PURCHASE CARD]" "RTN","PRCHNPO",18,0) I $G(PRCHPC)=3 S DR="[PRCH PC DIRECT DELIVERY]" "RTN","PRCHNPO",19,0) I $G(PRCHDELV)=1,'$G(PRCHPHAM) S DR="[PRCH DELIVERY ORDER]" "RTN","PRCHNPO",20,0) I $G(PRCHPHAM)=1 S DR="[PRCH DIRECT DELIVERY ORDER]" "RTN","PRCHNPO",21,0) D ^DIE "RTN","PRCHNPO",22,0) ; "RTN","PRCHNPO",23,0) ; Check ERRFLG to see if the user entered an up-arrow to get out or "RTN","PRCHNPO",24,0) ; did not select a credit card name. The flag ERRFLG is set at the "RTN","PRCHNPO",25,0) ; input templates above. "RTN","PRCHNPO",26,0) I $G(ERRFLG)=99 G ERR ;PRC*5.1*184 Check for error flag coming from Input Template for Purchase Cards "RTN","PRCHNPO",27,0) I $G(ERRFLG)=42 G ERR "RTN","PRCHNPO",28,0) I $G(ERRFLG)=38 G ERR "RTN","PRCHNPO",29,0) I $G(ERRFLG)=1 G ERR "RTN","PRCHNPO",30,0) I $G(ERRFLG)=2 G ERR "RTN","PRCHNPO",31,0) I $G(ERRFLG)=3 G ERR "RTN","PRCHNPO",32,0) ;Look for incomplete Input-Template when PRCHPC is defined. "RTN","PRCHNPO",33,0) I $D(PRCHPC) D "RTN","PRCHNPO",34,0) . I $D(Y)'=0 S NOTCOMPL=1 "RTN","PRCHNPO",35,0) I NOTCOMPL G INCMSG "RTN","PRCHNPO",36,0) I $G(PRCHPC)=1 Q:$D(Y) D Q:$D(Y) "RTN","PRCHNPO",37,0) . S:'$D(^PRC(442,PRCHPO,2,0)) $P(^PRC(442,PRCHPO,2,0),U,2)=$P(^DD(442,40,0),U,2) "RTN","PRCHNPO",38,0) . S DA(1)=PRCHPO,DIE="^PRC(442,"_DA(1)_",2,",DA=1 "RTN","PRCHNPO",39,0) . S DR=".01///^S X=1;1;I '$D(^PRC(442,DA(1),2,DA,1)) W !,""Description is Required!!"" S Y=1;2///^S X=1;3///^S X=""EA"";5////^S X=PRCHTOT;3.1///^S X=1;9.7///^S X=1;9///^S X="""";8///^S X=9999;K PRCHBOCC;" "RTN","PRCHNPO",40,0) . S DR(1,442.01,1)="I PRCHN(""SFC"")=2 S PRCHBOCC=2696;I '$G(PRCHBOCC) S Y=""@87"";" "RTN","PRCHNPO",41,0) . S DR(1,442.01,2)="S PRCHBOCC=$P($G(^PRCD(420.2,PRCHBOCC,0)),U);3.5////^S X=PRCHBOCC;S Y=""@89"";@87;3.5//^S X=PRCHBOC1;@89;K PRCHBOCC" "RTN","PRCHNPO",42,0) . D ^DIE Q:$D(Y) "RTN","PRCHNPO",43,0) . S DIE="^PRC(442,",DA=PRCHPO,DR=20 D ^DIE "RTN","PRCHNPO",44,0) PROS I $P($G(^PRC(442,PRCHPO,23)),U,11)]"" Q:$D(Y) D Q:$D(Y) Q:'$G(CDA) "RTN","PRCHNPO",45,0) . S PODIE=DIE,PODA=DA "RTN","PRCHNPO",46,0) . S CDA=$P($G(^PRC(442,PRCHPO,23)),U,23),PRC("CP")=$P($G(^PRC(442,PRCHPO,0)),U,3) "RTN","PRCHNPO",47,0) . I +$G(PRC("CP"))'=0 S DA=PRCHPO D START^PRCH410 I $G(PRCRMPR)=1,$G(X)="#" Q "RTN","PRCHNPO",48,0) . I '$G(PRCHPHAM),'$G(PRCPROST),+$G(PRC("CP"))'=0 S DIE="^PRCS(410,",DA=$P($G(^PRC(442,PRCHPO,23)),U,23),DR=16 D ^DIE "RTN","PRCHNPO",49,0) . S DIE=PODIE,DA=PODA "RTN","PRCHNPO",50,0) I $G(PRCRMPR)=1,X="#" Q "RTN","PRCHNPO",51,0) S VEN=+$G(^PRC(442,PRCHPO,1)) "RTN","PRCHNPO",52,0) I '$P($G(^PRC(442,PRCHPO,23)),U,11),$P($G(PRCHNVF),U,3)!($G(^PRC(440.3,+$G(VEN),0))]"") D "RTN","PRCHNPO",53,0) . I $P($G(^PRC(411,PRC("SITE"),9)),U,3)="Y" D Q "RTN","PRCHNPO",54,0) . . S PRCHXXDA=DA "RTN","PRCHNPO",55,0) . . S PRCHXDIE=DIE "RTN","PRCHNPO",56,0) . . S DA=VEN "RTN","PRCHNPO",57,0) . . Q:$$NEW^PRCOVTST(VEN,PRC("SITE"),1) "RTN","PRCHNPO",58,0) . . I $P($G(PRCHNVF),U,3) D "RTN","PRCHNPO",59,0) . . . S %X="^PRC(440,DA," "RTN","PRCHNPO",60,0) . . . S %Y="^PRC(440.3,DA," "RTN","PRCHNPO",61,0) . . . D %XY^%RCR "RTN","PRCHNPO",62,0) . . . Q "RTN","PRCHNPO",63,0) . . S DIE="^PRC(440.3,",DR="47///^S X=1;48///^S X=VEN;49///^S X=PRC(""SITE"")" "RTN","PRCHNPO",64,0) . . D ^DIE "RTN","PRCHNPO",65,0) . . S DA=PRCHXXDA "RTN","PRCHNPO",66,0) . . S DIE=PRCHXDIE "RTN","PRCHNPO",67,0) . . K PRCHXXDA "RTN","PRCHNPO",68,0) . . K PRCHXDIE "RTN","PRCHNPO",69,0) . D NEW^PRCOVRQ(VEN,PRC("SITE")) "RTN","PRCHNPO",70,0) K VEN "RTN","PRCHNPO",71,0) L +^PRC(442,PRCHPO):0 G ERR:'$T S PRCHSTAT=$P($G(^PRC(442,PRCHPO,7)),U,2) S:$D(Y)&('$D(PRCHNRQ))&(PRCHSTAT'=22) PRCHER="" S (PRCH,PRCHEC,PRCHX)=0 "RTN","PRCHNPO",72,0) S PRCHSC="" I $D(^PRC(442,PRCHPO,1)),$D(^PRCD(420.8,+$P(^(1),U,7),0)) S PRCHSC=$P(^(0),U,1) S $P(^PRC(442,PRCHPO,1),U,14)=$S(PRCHSC="B":"*",1:"") "RTN","PRCHNPO",73,0) ;K PRCHER F S PRCH=$O(^PRC(442,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D G ERR:$D(PRCHER) "RTN","PRCHNPO",74,0) K PRCHER F S PRCH=$O(^PRC(442,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D "RTN","PRCHNPO",75,0) .S $P(^PRC(442,PRCHPO,2,PRCH,2),U,6)="" "RTN","PRCHNPO",76,0) .S PRCHLN=$G(^PRC(442,PRCHPO,2,PRCH,0)) ;I PRCHLN="" D ERR2 Q "RTN","PRCHNPO",77,0) .S SUBACC=$P(PRCHLN,U,4) ;I SUBACC="" D ERR2 Q "RTN","PRCHNPO",78,0) .D ERR2 "RTN","PRCHNPO",79,0) .Q "RTN","PRCHNPO",80,0) K ^PRC(442,PRCHPO,2,"B"),^("C"),^("AC"),^("AE"),^("AH") "RTN","PRCHNPO",81,0) N PRCHCNYS,PRCHCNNO S (PRCHCNYS,PRCHCNNO)=0 ;FLGS FOR CONTRACT # ON ITEM "RTN","PRCHNPO",82,0) S PRCH=0 F I=1:1 S PRCH=$O(^PRC(442,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D CHG I $D(^PRC(442,PRCHPO,2,PRCH,0)) D "RTN","PRCHNPO",83,0) .S PRCHAM=+$P(^PRC(442,PRCHPO,2,PRCH,2),U,1),PRCHCN=$P(^(2),U,2) D CN:PRCHCN]"",OM:PRCHCN="" "RTN","PRCHNPO",84,0) .I PRCHCN]"" S PRCHCNYS=1 "RTN","PRCHNPO",85,0) .E S PRCHCNNO=1 "RTN","PRCHNPO",86,0) .S $P(^PRC(442,PRCHPO,2,PRCH,2),U,5)="" "RTN","PRCHNPO",87,0) .Q "RTN","PRCHNPO",88,0) S PRCHLCNT=I-1,$P(^PRC(442,PRCHPO,0),U,14)=PRCHLCNT S:$D(^PRC(442,PRCHPO,2,0)) $P(^(0),U,3,4)="1^"_PRCHLCNT I 'PRCHLCNT S PRCHER="" W !,"There are no line items listed in the Purchase Order." "RTN","PRCHNPO",89,0) G ERRCHKS:'$D(^PRC(442,PRCHPO,1))!('$D(^(2))) "RTN","PRCHNPO",90,0) I $P(^PRC(442,PRCHPO,0),U,3)=""!($P(^(0),U,4))="" W !!?5,"Fund Control Point is undefined !",$C(7) "RTN","PRCHNPO",91,0) S PRCHV=$P(^PRC(442,PRCHPO,1),U,1) I PRCHV="" W !!?5,"Vendor is undefined !",$C(7) ;G ERR "RTN","PRCHNPO",92,0) ERRCHKS S ERRFL=0 D ERRCHKS^PRCHNPO9 ;I ERRFL=0 K ERRFL G CONT "RTN","PRCHNPO",93,0) ;K ERRFL G ERR "RTN","PRCHNPO",94,0) CONT ; "RTN","PRCHNPO",95,0) S ERROR1="" D ^PRCHNPO9 "RTN","PRCHNPO",96,0) I ERROR1=1!(ERRFL>0)!($D(PRCHER)) G ERR "RTN","PRCHNPO",97,0) D BBFY^PRCHNPO8(PRCHPO) I PRC("BBFY")'>0 W !!?5,"BBFY can not be checked/updated.",$C(7) G ERR "RTN","PRCHNPO",98,0) S PRCH=0 F I=0:1 S PRCH=$O(PRCH("AM",PRCH)) Q:PRCH="" S PRCH("COUNT",+PRCH("AM",PRCH),PRCH)="" "RTN","PRCHNPO",99,0) I PRCHCNNO,PRCHCNYS D ASTR ; <<< only call on ASTR "RTN","PRCHNPO",100,0) G:I=1 ^PRCHNRQ:$D(PRCHNRQ),^PRCHNPO1 S J=1 F PRCHJ=0:0 S PRCH=$O(PRCH("COUNT",PRCH)) Q:PRCH="" D MISS "RTN","PRCHNPO",101,0) G ^PRCHNRQ:$D(PRCHNRQ),^PRCHNPO1 "RTN","PRCHNPO",102,0) ; "RTN","PRCHNPO",103,0) LI S PRCHL0=$P(PRCH("AM",PRCHL3),U,3) Q:PRCHL0="" F J=1:1 S PRCHL1=$E(PRCHL0,$L(PRCHL0)-J) Q:PRCHL1'=+PRCHL1 "RTN","PRCHNPO",104,0) S PRCHL2=$E(PRCHL0,$L(PRCHL0)-J+1,$L(PRCHL0)-1),PRCHL2=PRCHL2+1 I PRCHL2'=PRCHLI S PRCHLI=PRCHL0_PRCHLI Q "RTN","PRCHNPO",105,0) I PRCHL1=":" S PRCHLI=$E(PRCHL0,1,$L(PRCHL0)-J)_PRCHLI Q "RTN","PRCHNPO",106,0) S PRCHLI=$E(PRCHL0,1,$L(PRCHL0)-1)_":1:"_PRCHLI "RTN","PRCHNPO",107,0) Q "RTN","PRCHNPO",108,0) ; "RTN","PRCHNPO",109,0) CHG I '$P(^PRC(442,PRCHPO,2,PRCH,0),"^",5),'$O(^(1,0)) S $P(^PRC(442,PRCHPO,2,PRCH,2),U,4,6)="^^" W !,"Line item ",+^PRC(442,PRCHPO,2,PRCH,0)," is missing its description!" S PRCHER="" "RTN","PRCHNPO",110,0) S $P(^PRC(442,PRCHPO,2,PRCH,0),U,1)=I,X=$P(^(0),U,5),X1=$P(^(0),U,4) "RTN","PRCHNPO",111,0) S ^PRC(442,PRCHPO,2,"B",I,PRCH)="",^PRC(442,PRCHPO,2,"C",I,PRCH)="",^PRC(442,PRCHPO,2,"AH",+X1,I,PRCH)="",PRCHLI=I,PRCHX=PRCH S:X]"" ^PRC(442,PRCHPO,2,"AE",X,PRCH)="" "RTN","PRCHNPO",112,0) Q "RTN","PRCHNPO",113,0) ; "RTN","PRCHNPO",114,0) ERR2 I $S('$D(^PRC(442,PRCHPO,2,PRCH,2)):1,$P(^(2),U,1)="":1,1:0) S $P(^(2),U,1)="",$P(^(2),U,4,7)="" W !,"Line item ",+^(0)," is incomplete !",$C(7) S PRCHER="" "RTN","PRCHNPO",115,0) I '$G(PRCHPC),$D(PRCHNRQ),PRCHSC'=9,$P(^PRC(442,PRCHPO,2,PRCH,0),U,13)="" W !,"Line item ",+^(0)," is missing NSN !",$C(7) S PRCHER="" "RTN","PRCHNPO",116,0) I $P(^PRC(442,PRCHPO,2,PRCH,0),U,4)="" W !,"Line item ",+^(0)," is missing BOC !",!,$C(7) S PRCHER="" "RTN","PRCHNPO",117,0) Q "RTN","PRCHNPO",118,0) ; "RTN","PRCHNPO",119,0) CN S:'$D(PRCH("AM",PRCHCN)) PRCH("AM",PRCHCN)="",PRCHEC=PRCHEC+1 S PRCHL3=PRCHCN "RTN","PRCHNPO",120,0) D LI S PRCH("AM",PRCHCN)=($P(PRCH("AM",PRCHCN),U,1)+1)_U_($P(PRCH("AM",PRCHCN),U,2)+PRCHAM)_U_PRCHLI_",",^PRC(442,PRCHPO,2,"AC",$E(PRCHCN,1,30),PRCH)="" "RTN","PRCHNPO",121,0) Q "RTN","PRCHNPO",122,0) ; "RTN","PRCHNPO",123,0) OM S:'$D(PRCH("AM",".OM")) PRCH("AM",".OM")="",PRCHEC=PRCHEC+1 S PRCHL3=".OM" D LI S PRCH("AM",".OM")=($P(PRCH("AM",".OM"),U,1)+1)_U_($P(PRCH("AM",".OM"),U,2)+PRCHAM)_U_PRCHLI_"," "RTN","PRCHNPO",124,0) Q "RTN","PRCHNPO",125,0) ; "RTN","PRCHNPO",126,0) MISS S PRCHN=0 F K=1:1 S PRCHN=$O(PRCH("COUNT",PRCH,PRCHN)) Q:PRCHN=""!(J>(I-1)) S J=J+1,L=0,Y=$P(PRCH("AM",PRCHN),U,3),Y="F PRCHLI="_$E(Y,1,$L(Y)-1)_" S L=L+1 G ERR2:PRCHX<0" X Y "RTN","PRCHNPO",127,0) Q "RTN","PRCHNPO",128,0) ; "RTN","PRCHNPO",129,0) ASTR ;IF SOME ITEMS HAVE CN, SOME DO NOT, PLACE '*' ON DISPLAY OF PO "RTN","PRCHNPO",130,0) N CN,ITM,DESC,ROOT "RTN","PRCHNPO",131,0) S ROOT="^PRC(442,PRCHPO)" "RTN","PRCHNPO",132,0) S CN=0 F M=1:1 S CN=$O(@ROOT@(2,"AC",CN)) Q:CN="" S:$D(^(CN)) ITM=$O(^(CN,0)) S ^PRC(442,PRCHPO,2,"AC",CN,ITM)="*" "RTN","PRCHNPO",133,0) S:PRCHSC="B" $P(^PRC(442,PRCHPO,1),U,14)="*" "RTN","PRCHNPO",134,0) S DESC=0 F I=1:1 S DESC=$O(@ROOT@(2,DESC)) Q:DESC=""!(DESC'>0) I $P(@ROOT@(2,DESC,2),U,2)']"" S $P(^PRC(442,PRCHPO,2,DESC,2),U,5)="*" "RTN","PRCHNPO",135,0) ;S PRCHX=$O(^PRC(442,PRCHPO,2,"B",PRCHLI,0)) Q:PRCHX=""!('$D(^PRC(442,PRCHPO,2,PRCHX,2))) S $P(^(2),U,5)=PRCHN("*") S:PRCHN'=".OM" ^PRC(442,PRCHPO,2,"AC",PRCHN,PRCHLI)=PRCHN("*") "RTN","PRCHNPO",136,0) ;I PRCHSC="B",PRCHN=".OM",$D(^PRC(442,PRCHPO,1)),L=1 S ^(1)=$P(^(1),U,1,13)_U_PRCHN("*")_U_$P(^(1),U,15,99) "RTN","PRCHNPO",137,0) Q "RTN","PRCHNPO",138,0) ; "RTN","PRCHNPO",139,0) ERR ; "RTN","PRCHNPO",140,0) W !!?5,$S($D(PRCHNRQ):"Requisition",1:"Purchase Order")_" is incomplete and must be re-edited !",$C(7) "RTN","PRCHNPO",141,0) INCMSG ; "RTN","PRCHNPO",142,0) I '$D(NOTCOMPL) D "RTN","PRCHNPO",143,0) . S NOTCOMPL=0 "RTN","PRCHNPO",144,0) I NOTCOMPL D "RTN","PRCHNPO",145,0) . W !!,?5,"Incomplete transaction. It must be re-edited !",$C(7) "RTN","PRCHNPO",146,0) Q K ERRDEL,ERRPC,ERRPO,DR,NOTCOMPL,DRTY,IMF,IMFD,LI,MUL,MULMSG,PRCHDRTY,PRCHFSCD,PRCHLCNT,PRCHMUL,PRCHM10,PRCHMS10,PRCHMS11,PRCHUCF,PRTY,SUPUSR,UCF,UCFMSG,UFL,VND "RTN","PRCHNPO",147,0) G Q^PRCHNPO4 "RTN","PRCHNPO",148,0) ; "RTN","PRCHNPO",149,0) MSG ;Call by the "ENTRY ACTION" for Simplified PC (PRC*5.1*79) "RTN","PRCHNPO",150,0) NEW MSG "RTN","PRCHNPO",151,0) S MSG(1)="*********************************************" "RTN","PRCHNPO",152,0) S MSG(1,"F")="!!?15" "RTN","PRCHNPO",153,0) S MSG(2)="* IF THE ORDER IS MORE THAN $3000.00 *" "RTN","PRCHNPO",154,0) S MSG(2,"F")="!?15" "RTN","PRCHNPO",155,0) S MSG(3)="* OR IS ON A CONTRACT, YOU CANNOT USE *" "RTN","PRCHNPO",156,0) S MSG(3,"F")="!?15" "RTN","PRCHNPO",157,0) S MSG(4)="* SIMPLIFIED PURCHASE CARD. *" "RTN","PRCHNPO",158,0) S MSG(4,"F")="!?15" "RTN","PRCHNPO",159,0) S MSG(5)="* YOU MUST USE DETAILED PURCHASE CARD!! *" "RTN","PRCHNPO",160,0) S MSG(5,"F")="!?15" "RTN","PRCHNPO",161,0) S MSG(6)="*********************************************" "RTN","PRCHNPO",162,0) S MSG(6,"F")="!?15" "RTN","PRCHNPO",163,0) S MSG(7,"F")="!" "RTN","PRCHNPO",164,0) ; "RTN","PRCHNPO",165,0) D EN^DDIOL(.MSG) "RTN","PRCHNPO",166,0) QUIT "RTN","PRCHNPOB") 0^3^B4314054^n/a "RTN","PRCHNPOB",1,0) PRCHNPOB ;RGB-TRANSACTION UTILITY PROGRAM ; 4/2/01 10:18 AM "RTN","PRCHNPOB",2,0) V ;;5.1;IFCAP;**184**;Oct 20, 2000;Build 8 "RTN","PRCHNPOB",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCHNPOB",4,0) ; "RTN","PRCHNPOB",5,0) ;PRC*5.1*184 RGB 9/5/13 Check to insure Purchase card orders for "RTN","PRCHNPOB",6,0) ;selected FCP have >5 requisition entries still available for use, "RTN","PRCHNPOB",7,0) ;otherwise PCard order will prevent user from continuing. "RTN","PRCHNPOB",8,0) ; "RTN","PRCHNPOB",9,0) EN(SITE,FCP) ;CHECK FOR NEW TRANSACTION (FILE 410) NUMBER AVAILABILITY FOR PCARD ORDERS "RTN","PRCHNPOB",10,0) EN1 N PRCHFCPA,PRCHDA,PRCHSEQ,PRCHSEQN,PRCHTOT,PRCHIEN,PRCHEND,PRCHMSG,PRCHI,PRCHREQ "RTN","PRCHNPOB",11,0) S PRCHMSG="",PRCHEND=0,PRCHFCPA=SITE_"-"_PRC("FY")_"-"_$P(FCP," "),PRCHTOT=0 "RTN","PRCHNPOB",12,0) I '$D(^PRCS(410.1,"B",PRCHFCPA)) Q "RTN","PRCHNPOB",13,0) S PRCHDA=$O(^PRCS(410.1,"B",PRCHFCPA,0)) S PRCHSEQ=$P(^PRCS(410.1,PRCHDA,0),"^",2)+1 S:PRCHSEQ>9999 PRCHSEQ=1 "RTN","PRCHNPOB",14,0) CHK F PRCHI=PRCHSEQ:1:9999 S PRCHSEQN="000"_PRCHI,PRCHSEQ=$E(PRCHSEQN,$L(PRCHSEQN)-3,$L(PRCHSEQN)),PRCHREQ=$P(PRCHFCPA,"-",1,2)_"-"_PRC("QTR")_"-"_$P(PRCHFCPA,"-",3)_"-"_PRCHSEQ D Q:PRCHTOT>5 "RTN","PRCHNPOB",15,0) . I '$D(^PRCS(410,"B",PRCHREQ)) S PRCHTOT=PRCHTOT+1 Q "RTN","PRCHNPOB",16,0) . S PRCHIEN=$O(^PRCS(410,"B",PRCHREQ,0)) "RTN","PRCHNPOB",17,0) . I $P($G(^PRCS(410,PRCHIEN,0)),U,2)="CA" S PRCHTOT=PRCHTOT+1 W !,PRCHIEN,!,^PRCS(410,PRCHIEN,0) "RTN","PRCHNPOB",18,0) I PRCHEND=0,PRCHTOT'>5 S PRCHSEQ=1,PRCHEND=1,PRCHTOT=0 G CHK "RTN","PRCHNPOB",19,0) CER I PRCHTOT'>5 S PRCHMSG=1 W !!,"ORDER ABORTED ==>>",!,"Insufficient sequence numbers remaining for "_$P(PRCHREQ,"-",1,4)_" during ORDER ENTRY",! "RTN","PRCHNPOB",20,0) Q PRCHMSG "RTN","PRCSEB") 0^4^B21871782^B19745869 "RTN","PRCSEB",1,0) PRCSEB ;SF-ISC/LJP/SAW/DXH/DAP - CPA EDITS CON'T ;7.26.99 "RTN","PRCSEB",2,0) V ;;5.1;IFCAP;**81,174,184**;Oct 20, 2000;Build 8 "RTN","PRCSEB",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCSEB",4,0) ; "RTN","PRCSEB",5,0) ;PRC*5.1*184 Check for error message indicating no 2237 seq nos. "RTN","PRCSEB",6,0) ; remaining to be used out of the max 9999 available "RTN","PRCSEB",7,0) ; for FCP FY-FQ. "RTN","PRCSEB",8,0) ; "RTN","PRCSEB",9,0) ENRB ;ENTER CP CLERK REQUEST FROM OPTION PRCSENRB "RTN","PRCSEB",10,0) D ENF^PRCSUT(1) G W2:'$D(PRC("SITE")) G EXIT:'$D(PRC("QTR"))!(Y<0) "RTN","PRCSEB",11,0) S MSG="" D EN1^PRCSUT3 Q:'X I MSG'="" W !!,MSG,! S DIR(0)="EAO",DIR("A")="Press to exit processing..." D ^DIR K DIR,MSG Q ;PRC*5.1*184 "RTN","PRCSEB",12,0) K MSG ;PRC*5.1*184 "RTN","PRCSEB",13,0) S PRCSX1=X D EN2^PRCSUT3 Q:'$D(PRCSX1) S X=PRCSX1,T1=DA D W L +^PRCS(410,DA):15 G ENRB:$T=0 I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS2=1 "RTN","PRCSEB",14,0) ; "RTN","PRCSEB",15,0) ;*81 Check site parameter to see if issue books should be allowed "RTN","PRCSEB",16,0) D CKPRM "RTN","PRCSEB",17,0) W !!,PRCVY,!! "RTN","PRCSEB",18,0) TYPE ; "RTN","PRCSEB",19,0) S PRCDAA=DA,DIC="^PRCS(410.5,",DIC(0)="AEQZ",DIC("A")="FORM TYPE: ",DIC("S")=PRCVX D ^DIC S TYPE=+Y,DA=PRCDAA "RTN","PRCSEB",20,0) I TYPE<2 W "?? EXIT NOT ALLOWED" G TYPE "RTN","PRCSEB",21,0) K PRCVX,PRCVY "RTN","PRCSEB",22,0) S $P(^PRCS(410,DA,0),"^",4)=TYPE S:$G(PRCSIP) $P(^PRCS(410,DA,0),"^",6)=PRCSIP S (DIE,DIC)="^PRCS(410,",X=TYPE "RTN","PRCSEB",23,0) ;NOTE THAT THE FOLLOWING LINE OVERWRITES THE USER'S SELECTION OF FORM "RTN","PRCSEB",24,0) ;TYPE IF THE FUND CONTROL POINT IS NOT 'AUTOMATED' "RTN","PRCSEB",25,0) S:'$D(PRCS2)&(X>2) $P(^PRCS(410,DA,0),"^",4)=2,X=2 "RTN","PRCSEB",26,0) S (PRCSDR,DR)="["_$S(X=2:"PRCSEN2237B",X=3:"PRCSENPR",X=4:"PRCSENR&NR",1:"PRCSENIB")_"]" "RTN","PRCSEB",27,0) EN1 K DTOUT,DUOUT,Y S PRCSDAA=DA D ^DIE I $D(Y)!($D(DTOUT)) S DA=PRCSDAA L -^PRCS(410,DA) G EXIT "RTN","PRCSEB",28,0) S DA=PRCSDAA D RL^PRCSUT1 "RTN","PRCSEB",29,0) D ^PRCSCK I $D(PRCSERR),PRCSERR G EN1 "RTN","PRCSEB",30,0) K PRCSERR "RTN","PRCSEB",31,0) I PRCSDR="[PRCSENCOD]" D W7^PRCSEB0 D:$D(PRCSOB) ENOD1^PRCSEB1 K PRCSOB "RTN","PRCSEB",32,0) S:$P($G(^PRCS(410,DA,7)),"^")="" $P(^PRCS(410,DA,7),"^")=DUZ "RTN","PRCSEB",33,0) D:PRCSDR'="[PRCSENCOD]" W1 I $D(PRCS2),+^PRCS(410,DA,0) D W6 "RTN","PRCSEB",34,0) S DA=PRCSDAA L -^PRCS(410,DA) D W3 G EXIT:%'=1 W !! K PRCS,PRCS2 "RTN","PRCSEB",35,0) G ENRB "RTN","PRCSEB",36,0) W W !!,"This transaction is assigned transaction number: ",X Q "RTN","PRCSEB",37,0) W1 W !!,"Would you like to review this request" S %=2 D YN^DICN G W1:%=0 Q:%'=1 S (N,PRCSZ)=DA,PRCSF=1 D PRF1^PRCSP1 S DA=PRCSZ K X,PRCSF,PRCSZ Q "RTN","PRCSEB",38,0) W2 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 G EXIT "RTN","PRCSEB",39,0) W3 W !!,"Would you like to enter another request" S %=1 D YN^DICN G W3:%=0 Q "RTN","PRCSEB",40,0) W5 S:'$D(^PRCS(410,DA,11)) ^(11)="" S $P(^(11),U,3)="" K ^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$P($P(^PRCS(410,DA,0),U),"-",5),DA),^PRCS(410,"F1",$P($P(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA) Q "RTN","PRCSEB",41,0) W51 S:'$D(^PRCS(410,DA,11)) ^(11)="" S $P(^(11),U,3)=1,(^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$P($P(^PRCS(410,DA,0),U),"-",5),DA),^PRCS(410,"F1",$P($P(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA))="" Q "RTN","PRCSEB",42,0) W6 N JUMP,SKIPRNT,OK,TEST,TEST1,CURQTR,CURQTR1 "RTN","PRCSEB",43,0) W61 ; "RTN","PRCSEB",44,0) N REPORT2 I $P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),1,DUZ,0)),"^",2)'=1 S REPORT2=1 D T1^PRCSAPP1 "RTN","PRCSEB",45,0) ;*****PRC*5.1*174 start***** "RTN","PRCSEB",46,0) ;if Level of Access is not Control Point Official DO block "RTN","PRCSEB",47,0) I $P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),1,DUZ,0)),"^",2)'=1 D Q "RTN","PRCSEB",48,0) . N PRCFTYPE S PRCFTYPE=+$$GET1^DIQ(410,$G(DA)_",",3,"I") ;Form Type "RTN","PRCSEB",49,0) . S %=1 "RTN","PRCSEB",50,0) . ;if request is a 2237 (Form Type IEN 2,3, or 4) "RTN","PRCSEB",51,0) . I $G(PRCFTYPE)>1&($G(PRCFTYPE)<5) D "RTN","PRCSEB",52,0) . . ;don't allow approval of 2237 if Requesting Service OR any line item description is missing "RTN","PRCSEB",53,0) . . I '$$REQCHECK^PRCHJUTL($G(DA),,1) S %=2 "RTN","PRCSEB",54,0) . I $G(%)'=2 S %=1 W !,"Is this request ready for approval" D YN^DICN "RTN","PRCSEB",55,0) . D:%=1 W51 "RTN","PRCSEB",56,0) . D:%=0 W61 "RTN","PRCSEB",57,0) . D:%=2 W5 "RTN","PRCSEB",58,0) ;*****PRC*5.1*174 end****** "RTN","PRCSEB",59,0) S PRCSN=^PRCS(410,DA,0),PRCHQ=$P(PRCSN,"^",4),PRC("FY")=$P(PRCSN,"-",2),PRC("QTR")=$P(PRCSN,"-",3) "RTN","PRCSEB",60,0) S (CURQTR,CURQTR1)=PRC("QTR"),(JUMP,TEST,TEST1,OK)=0 "RTN","PRCSEB",61,0) D T1^PRCSAPP1 I OK=1 S SKIPRNT=1 D FINAL^PRCSAPP2 "RTN","PRCSEB",62,0) Q "RTN","PRCSEB",63,0) ;*81 Site Parameter Check "RTN","PRCSEB",64,0) CKPRM I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVX="I Y>1&(Y<5)",PRCVY="The form types 1358, Issue Book, and NO FORM are no longer used within this option." "RTN","PRCSEB",65,0) I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVX="I Y>1",PRCVY="The form types 1358 and NO FORM are no longer used within this option" "RTN","PRCSEB",66,0) Q "RTN","PRCSEB",67,0) ; "RTN","PRCSEB",68,0) EXIT K %,C,D,DA,DIC,DIE,DQ,DR,PRCS,PRCS2,PRCSDAA,PRCSDR,PRCSERR,PRCSL,PRCSTT,I,N,T,T1,T2,X,X1,PRCSX3,Y,Z Q "VER") 8.0^22.0 "BLD",7367,6) ^168 **END** **END**