86 lines
5.1 KiB
Mathematica
86 lines
5.1 KiB
Mathematica
RMPR29B ;PHX/JLT-EDIT JOB SECTION[ 09/30/94 11:52 AM ]
|
|
;;3.0;PROSTHETICS;;Feb 09, 1996
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
MU ;ENTER DATEE
|
|
D DISP^RMPR29J I '$D(RMPRWO) G END
|
|
TCH ;TECHNICIAN DATE
|
|
;see internal notes
|
|
K DIR,DIC,DA,Y
|
|
S DIR(0)="664.3,.01O",DIR("A")="Select DATE"
|
|
S DIR("?")="^D LBR^RMPR29B" D ^DIR
|
|
G:$D(DTOUT) CDT G:$D(DIRUT) CHK
|
|
D SLK^RMPR29M,^DIC K DLAYGO,DIC
|
|
G:+Y'>0 TCH S RDA=Y
|
|
;verify new entry
|
|
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
|
|
;
|
|
S DA=+RDA,DIE="^RMPR(664.3,"
|
|
S DR=$S($P(RDA,U,3):"1////^S X=DA660;2////^S X=RMPR(""STA"");.01",1:".01")
|
|
D ^DIE I '$D(DA) G TCH
|
|
K DIC,Y,DA S DA(1)=+RDA,DLAYGO=664.3,DIC(0)="AEQLM"
|
|
S DIC="^RMPR(664.3,"_DA(1)_",1,",DIC("P")="664.33PA"
|
|
S DIC("B")=$$EMP^RMPR31U(DUZ) D ^DIC K DLAYGO
|
|
;
|
|
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
|
|
G TCH
|
|
;
|
|
LBR ;Help for DIR
|
|
D SLK^RMPR29M S X="?" D ^DIC K DIC,DLAYGO
|
|
Q
|
|
CHKN ;verify new entry
|
|
K DIR W $C(7),?5
|
|
S DIR(0)="Y",DIR("A")="ARE YOU ADDING A NEW DATE FOR THIS JOB"
|
|
D ^DIR
|
|
I +Y=0 S DA=+RDA,DIK="^RMPR(664.3," D ^DIK G TCH
|
|
CHK ;Check to see if GIP is on
|
|
I $P(^RMPR(669.9,RMPRSITE,0),U,3) K DIC,PRCP G INV
|
|
JB ;process job data
|
|
K DIC S DIC="^RMPR(664.2,"_RMPRWO_",1,",DIC("P")="664.22PA"
|
|
S DA(1)=RMPRWO,DIC(0)="AEQMZL"
|
|
S DIC("W")="S RR=$P(^(0),U,1) W ?16,$$ITM^RMPR31U(RR)"
|
|
S DIC("S")="I '$P(^(0),U,11)&'$P(^(0),U,13)",DLAYGO=664.2
|
|
W ! D ^DIC K DLAYGO
|
|
I +Y'>0 G CDT
|
|
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)
|
|
EDT 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
|
|
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 JB
|
|
INV ;INVENTORY POINT
|
|
I '$D(^PRCP(445,"AD",DUZ)) W !!,?5,$C(7),"You are not an Inventory User" G CDT
|
|
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
|
|
IMU W ! K DIR,VEN
|
|
S DIR(0)="FO",DIR("A")="MATERIALS USED"
|
|
S DIR("?")="^S ZFL=1 D ZDSP^RMPR29R"
|
|
D ^DIR G:$D(DTOUT) END G:$D(DIRUT) INV
|
|
K DIC S DIC=661,DIC(0)="EQMZ"
|
|
S DIC("S")="S RA=$P(^(0),U,1) I $D(^PRCP(445,""AE"",RA,PRCP(""I"")))"
|
|
D ^DIC G:+Y'>0 IMU S HY=+Y,ITM=$P(Y,U,2)
|
|
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
|
|
I '$D(^RMPR(664.2,RMPRWO,1,0)) S ^RMPR(664.2,RMPRWO,1,0)="^664.22PA^0^0"
|
|
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
|
|
IEDT S COST=$P(^RMPR(664.2,RMPRWO,1,DA,0),U,3)
|
|
I 'COST D INVD^RMPR29U(PRCP("I"),ITM)
|
|
S RDA=^RMPR(664.2,RMPRWO,1,DA,0)
|
|
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"
|
|
D ^DIE G:$D(DTOUT) END
|
|
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
|
|
I $D(PRCP) S RMPRINV=PRCP("I") D PINV S PRCP("I")=RMPRINV
|
|
G IMU
|
|
PINV 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
|
|
W !!,$C(7),"POSTING TO INVENTORY",$P(^PRCP(445,RMPRINV,0),U,1)
|
|
REP 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
|
|
.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
|
|
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
|
|
Q
|
|
END G DISP^RMPR29D
|
|
ERR W !!,$C(7),"ITEM DID NOT POST TO G.I.P." Q
|
|
CDT S DIE="^RMPR(664.2,",DR="12;10",DA=RMPRWO D ^DIE G:$D(Y) POST
|
|
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
|
|
.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
|
|
.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
|
|
I '$D(^RMPR(664.3,"C",DA660))&'$O(^RMPR(664.2,RMPRWO,1,0)) G POST
|
|
I RDA G POST
|
|
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///@")
|
|
D ^DIE
|
|
POST D POST^RMPR29U G MU
|