source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29B.m@ 1800

Last change on this file since 1800 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1RMPR29B ;PHX/JLT-EDIT JOB SECTION[ 09/30/94 11:52 AM ]
2 ;;3.0;PROSTHETICS;;Feb 09, 1996
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4MU ;ENTER DATEE
5 D DISP^RMPR29J I '$D(RMPRWO) G END
6TCH ;TECHNICIAN DATE
7 ;see internal notes
8 K DIR,DIC,DA,Y
9 S DIR(0)="664.3,.01O",DIR("A")="Select DATE"
10 S DIR("?")="^D LBR^RMPR29B" D ^DIR
11 G:$D(DTOUT) CDT G:$D(DIRUT) CHK
12 D SLK^RMPR29M,^DIC K DLAYGO,DIC
13 G:+Y'>0 TCH S RDA=Y
14 ;verify new entry
15 I $P(Y,U,3) K DIR W $C(7),?5 S DIR(0)="Y",DIR("A")="ARE YOU ADDING A NEW DATE FOR THIS JOB" D ^DIR G:$D(DTOUT)!(X="^") CHK I +Y=0 S DA=+RDA,DIK="^RMPR(664.3," D ^DIK G TCH
16 ;
17 S DA=+RDA,DIE="^RMPR(664.3,"
18 S DR=$S($P(RDA,U,3):"1////^S X=DA660;2////^S X=RMPR(""STA"");.01",1:".01")
19 D ^DIE I '$D(DA) G TCH
20 K DIC,Y,DA S DA(1)=+RDA,DLAYGO=664.3,DIC(0)="AEQLM"
21 S DIC="^RMPR(664.3,"_DA(1)_",1,",DIC("P")="664.33PA"
22 S DIC("B")=$$EMP^RMPR31U(DUZ) D ^DIC K DLAYGO
23 ;
24 I +Y>0 S DIE=DIC,DA(1)=+RDA,DA=+Y,DR=".01;1" D ^DIE I $D(DA) S EMP=+$P($G(^RMPR(664.3,DA(1),1,DA,0)),U) S:'$P(^RMPR(664.3,DA(1),1,DA,0),U,3) $P(^RMPR(664.3,DA(1),1,DA,0),U,3)=$$PAID^RMPR29U(EMP) S DIE=DIC,DR="2R" D ^DIE
25 G TCH
26 ;
27LBR ;Help for DIR
28 D SLK^RMPR29M S X="?" D ^DIC K DIC,DLAYGO
29 Q
30CHKN ;verify new entry
31 K DIR W $C(7),?5
32 S DIR(0)="Y",DIR("A")="ARE YOU ADDING A NEW DATE FOR THIS JOB"
33 D ^DIR
34 I +Y=0 S DA=+RDA,DIK="^RMPR(664.3," D ^DIK G TCH
35CHK ;Check to see if GIP is on
36 I $P(^RMPR(669.9,RMPRSITE,0),U,3) K DIC,PRCP G INV
37JB ;process job data
38 K DIC S DIC="^RMPR(664.2,"_RMPRWO_",1,",DIC("P")="664.22PA"
39 S DA(1)=RMPRWO,DIC(0)="AEQMZL"
40 S DIC("W")="S RR=$P(^(0),U,1) W ?16,$$ITM^RMPR31U(RR)"
41 S DIC("S")="I '$P(^(0),U,11)&'$P(^(0),U,13)",DLAYGO=664.2
42 W ! D ^DIC K DLAYGO
43 I +Y'>0 G CDT
44 S DA=+Y,ITM=$$ITM1^RMPR31U($P(Y,U,2)),VDR=$P($G(^PRC(440,+$P(Y(0),U,6),0)),U),COST=$P(Y(0),U,3) D:VDR="" ITV^RMPR29U(VDR,ITM) D:'COST ITC^RMPR29U(VDR,ITM)
45EDT K DR S DIE="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO,DR=".01R;3R;5R//^S X=$G(VDR);I $P(^RMPR(664.2,DA(1),1,DA,0),U,4)=""V"" S $P(^(0),U,3)=0,Y=""@1"";2R//^S X=$J($G(COST),0,2);@1;1R;6R;7" D ^DIE G:$D(DTOUT) END
46 I $D(DA) I $P(^RMPR(664.2,RMPRWO,1,DA,0),U,1)=""!($P(^(0),U,2)="")!($P(^(0),U,3)="") S DIK=DIE,DA(1)=RMPRWO D ^DIK W !!,?5,$C(7),"Deleted..."
47 G JB
48INV ;INVENTORY POINT
49 I '$D(^PRCP(445,"AD",DUZ)) W !!,?5,$C(7),"You are not an Inventory User" G CDT
50 W ! S DIC="^PRCP(445,",DIC(0)="AEQMZ",DIC("A")="Select INVENTORY POINT: ",DIC("S")="I $P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))",PRCPPRIV=1 D ^DIC G:+Y'>0 CDT S (RMPRINV,PRCP("I"))=+Y
51IMU W ! K DIR,VEN
52 S DIR(0)="FO",DIR("A")="MATERIALS USED"
53 S DIR("?")="^S ZFL=1 D ZDSP^RMPR29R"
54 D ^DIR G:$D(DTOUT) END G:$D(DIRUT) INV
55 K DIC S DIC=661,DIC(0)="EQMZ"
56 S DIC("S")="S RA=$P(^(0),U,1) I $D(^PRCP(445,""AE"",RA,PRCP(""I"")))"
57 D ^DIC G:+Y'>0 IMU S HY=+Y,ITM=$P(Y,U,2)
58 I $D(^RMPR(664.2,RMPRWO,1,"B",+Y)) S DA=$O(^RMPR(664.2,RMPRWO,1,"B",+Y,0)) W:$P(^RMPR(664.2,RMPRWO,1,DA,0),U,11) $C(7) G:$P(^(0),U,11) IMU S VEN=$P($G(^PRC(440,+$P(^(0),U,6),0)),U) G IEDT
59 I '$D(^RMPR(664.2,RMPRWO,1,0)) S ^RMPR(664.2,RMPRWO,1,0)="^664.22PA^0^0"
60 S DIC="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO,DIC(0)="LZ",X=HY D FILE^DICN G:+Y'>0 END S DA=+Y
61IEDT S COST=$P(^RMPR(664.2,RMPRWO,1,DA,0),U,3)
62 I 'COST D INVD^RMPR29U(PRCP("I"),ITM)
63 S RDA=^RMPR(664.2,RMPRWO,1,DA,0)
64 S DIE="^RMPR(664.2,"_RMPRWO_",1,",DA(1)=RMPRWO,DR=".01;3R;4////^S X=RMPRINV;5//^S X=VEN;2///^S X=+$J($G(COST),0,2);I $P(^RMPR(664.2,DA(1),1,DA,0),U,4)=""V"" S $P(^RMPR(664.2,DA(1),1,DA,0),U,3)=0,Y=""@1"";2R;@1;1R;6R;7"
65 D ^DIE G:$D(DTOUT) END
66 I $D(DA) I $P(^RMPR(664.2,RMPRWO,1,DA,0),U,1)=""!($P(^(0),U,2)="")!($P(^(0),U,3)="") S DIK=DIE,DA(1)=RMPRWO D ^DIK W !!,?5,$C(7),"Deleted..." G IMU
67 I $D(PRCP) S RMPRINV=PRCP("I") D PINV S PRCP("I")=RMPRINV
68 G IMU
69PINV G:'$D(DA) REP S RNW=^RMPR(664.2,RMPRWO,1,DA,0) I +RNW=+RDA,$P(RNW,U,2)=$P(RDA,U,2),$P(RNW,U,5)=$P(RDA,U,5) Q
70 W !!,$C(7),"POSTING TO INVENTORY",$P(^PRCP(445,RMPRINV,0),U,1)
71REP I $P(RDA,U,5),$P(RDA,U,1),$P(RDA,U,2) S PRCP("QTY")=$P(RDA,U,2),PRCP("ITEM")=$P(^RMPR(661,$P(RDA,U,1),0),U,1),PRCP("TYP")="A" D
72 .I $D(^PRCP(445,PRCP("I"),0)),$P(^(0),U,2)="Y" W:'$D(DA) $C(7),!!,?5,"UPDATING INVENTORY" D ^PRCPUSA D:$D(PRCP) ERR K RDA,RNW
73 Q:'$D(DA) S PRCP("I")=$P(^RMPR(664.2,RMPRWO,1,DA,0),U,5),PRCP("QTY")=$P(^(0),U,2)*-1,PRCP("ITEM")=$P(^RMPR(661,$P(^(0),U,1),0),U,1),PRCP("TYP")="R" D ^PRCPUSA K RDA,RNW I $D(PRCP) D ERR
74 Q
75END G DISP^RMPR29D
76ERR W !!,$C(7),"ITEM DID NOT POST TO G.I.P." Q
77CDT S DIE="^RMPR(664.2,",DR="12;10",DA=RMPRWO D ^DIE G:$D(Y) POST
78 K RSTOP F RDA=0:0 S RDA=$O(^RMPR(664.2,RMPRWO,1,RDA)) Q:RDA'>0 I $D(^(RDA,0)) S RRA=^(0) D I $D(RSTOP) H 3 Q
79 .I $D(^RMPR(664,+$P(RRA,U,11),0)),'$P(^(0),U,8) W !!,$C(7),?5,"Work Order has a 2421 Request that has not been Delivered",!,?5,"This job cannot be completed" S RSTOP=1
80 .I $D(^RMPR(664.1,+$P(RRA,U,13),0)),'$P(^(0),U,26) W !!,$C(7),?5,"Work Order has a 2529-3 Request that has not been Delivered",!,?5,"This job cannot be completed" S RSTOP=1
81 I '$D(^RMPR(664.3,"C",DA660))&'$O(^RMPR(664.2,RMPRWO,1,0)) G POST
82 I RDA G POST
83 S:'$P(^RMPR(664.2,RMPRWO,0),U,11) $P(^(0),U,11)=DUZ S DIE="^RMPR(664.2,",DA=RMPRWO,DR="11;8" D ^DIE S DR=$S($P(^RMPR(664.2,RMPRWO,0),U,10):"9R",1:"9///@")
84 D ^DIE
85POST D POST^RMPR29U G MU
Note: See TracBrowser for help on using the repository browser.