source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPSC.m@ 868

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

initial load of FOIAVistA 6/30/08 version
File size: 3.4 KB
Line 
1RMPRPSC ;PHX/HNB-PRINT PSC LISTING ;8/29/1994
2 ;;3.0;PROSTHETICS;;Feb 09, 1996
3EN ;entry to Prosthetic Service Card from purchasing
4 W !!?7,"NAME",?50,"SERIAL NUMBER",!
5 S RMPRX=0 F I=0:0 S I=$O(^RMPR(665,RMPRDFN,5,I)) Q:I'>0 D PRT
6 R !!,"SELECT NUMBER: ",RMPRPC:DTIME I '$T!(RMPRPC["^") S RMPRFLG=1 Q
7 I '$D(^RMPR(665,RMPRDFN,5,+RMPRPC,0)) W !?5,$C(7),$C(7),"To obligate funds on this transaction, the veteran must",!?5,"have a PSC issued for that item." G EN
8 S RMPRPI=$P(^RMPR(665,RMPRDFN,5,+RMPRPC,0),U,4) I RMPRPI="" W !,$C(7) G EN
9 S RMPRSR(RMPRPI)=$P(^RMPR(665,RMPRDFN,5,+RMPRPC,0),U,3)
10 S RMPRPI=$P(^RMPR(661,RMPRPI,0),U,1)
11 ;MUST PASS RMPRSR,RMPRPI TO RMPR21 TO POST SERIAL NUMBERS
12 K RMPRX,RMPRIN,RMPRI,RMPRPC Q
13 ;
14PRT ;print items
15 S RMPRX=^RMPR(665,RMPRDFN,5,I,0),RMPRI=$P(RMPRX,U,4) I RMPRI'="" S RMPRIN=$P(^RMPR(661,RMPRI,0),U,1),RMPRIN=$E($P(^PRC(441,RMPRIN,0),U,2),1,30)
16 I RMPRI'="" W !,I_".",?7,$S($P(RMPRX,U,2)?1A.E:$P(RMPRX,U,2),1:RMPRIN),?50,$P(RMPRX,U,3)
17 Q
18PSC ;ENTRY POINT FOR CREATING PSC ITEMS FOR A PATIENT
19 S DIC="^RMPR(665,",DIC(0)="AEQMZ" D ^DIC G:+Y'>0 EXIT S RMPRDFN=+Y
20DT ;ENTER EDIT PSC CARD
21 I '$D(^RMPR(665,RMPRDFN,5)) S ^RMPR(665,RMPRDFN,5,0)="^665.012ID^0^0"
22 S DIC="^RMPR(665,"_RMPRDFN_",5,",DIC(0)="AEQMZL",DLAYGO=665
23 S DIC("W")="W "" "",$S($P(^(0),U,2)]"""":$E($P(^(0),U,2),1,30),$D(^RMPR(661,+$P(^(0),U,4),0)):$E($P(^PRC(441,$P(^(0),U,1),0),U,2),1,30),1:"""")_"" ""_$P(^RMPR(665,RMPRDFN,5,Y,0),U,3)"
24 D ^DIC K DLAYGO I +Y'>0 K DIC,DIE,DA,Y G:$D(RFL) EXIT G PSC
25 L +^RMPR(665,RMPRDFN,5,+Y):1 I $T=0 W !,?5,$C(7),"Someone is Editing this entry!" G EXIT
26 S DIE=DIC,NEW=+$P(Y,U,3),DA(1)=RMPRDFN,(DA,RDA)=+Y S DR=$S(NEW:".01:1",'NEW:".01:3") D ^DIE L -^RMPR(665,RMPRDFN,5,RDA)
27 I '$D(^RMPR(665,RMPRDFN,5,RDA,0)) G DT
28 I $D(^RMPR(665,DA(1),5,DA,0))&'$P(^(0),U,4) S DIK="^RMPR(665,"_RMPRDFN_",5,",DA(1)=RMPRDFN D ^DIK W !,?5,$C(7),"Deleted..." K DIE,DIC,DA G DT
29 G:'NEW DT S DR="2:3" D ^DIE G DT
30EXIT ;common exit point
31 Q:$D(RMPRFLAG) K DIC,DIE,R90,RDA,DR,NEW Q
32EYE ;EDIT FOR EYE GLASSES
33 ;
34 S VENDOR=$$VEN^RMPR31U($P($G(^RMPR(660.5,+$G(RMPRDA),0)),U,4))
35 I VENDOR="Vendor not found" S VENDOR=""
36 S DR="4//^S X=VENDOR" D ^DIE K VENDOR
37 I $D(DTOUT)!($D(Y)'=0) G KILL^RMPR21
38 ;
39AA S X=$P($G(^RMPR(669.9,RMPRSITE,3)),U,3) I X'="" S DIC("B")=$$ITM^RMPR31U(X)
40 K DIC,Y S DIC=661,DIC(0)="AEQMZ",DIC("A")="ITEM (for AMIS): ",DIC("S")="S Z=$P(^(0),U,3),R1=$P(^(0),U,4) I +R1>0,+Z>0 I $P(^RMPR(663,+Z,0),U,1)=11!($P(^RMPR(663,+R1,0),U,1)=""R06"")" D ^DIC I +Y'>0 G KILL^RMPR21
41 K DIC,Y S DIC=661,DIC(0)="MZ",X="EYEGLASSES",DIC("S")="S R90=$P(^(0),U,3),R1=$P(^(0),U,4) I +R1>0,+R90>0 I $P(^RMPR(663,+R90,0),U,1)=11!($P(^RMPR(663,+R1,0),U,1)=""R06"")" D ^DIC I +Y'>0 G KILL^RMPR21
42 K DIC,DIE S RMPRPI=$P(Y,U,2) S DIE="^RMPR(664,",DR="[RMPREYE]"
43 D ^DIE G CHK^RMPR21
44PRCS ;ENTRY POINT FOR DISPLAYING 1358 BALANCE
45 D EN3^PRCSUT I Y=-1 Q
46 K PRCS W !,"Select OBLIGATION NUMBER: ",RMPROB,"// " R X:DTIME S:'$T X="^" W:X["?" !!,?5,"Please Enter '^' to Exit" Q:X["^" S X=$S(X="":RMPROB,1:X) S DIC("S")="S RX=^(0) I +RX=+PRC(""SITE""),+$P(RX,U,3)=+PRC(""CP""),+$P(RX,U,2)=21"
47 S DIC=442,DIC(0)="MQXZ" D ^DIC G:+Y'>0 PRCS S RMPROB=$P(Y,U,2)
48BAL ;check IFCAP version
49 S RDA=$O(^DIC(9.4,"C","PRC",0)) I $D(^DIC(9.4,+RDA,"VERSION")) S RVA=+^("VERSION")
50 I +RVA<4 W !,"1358 Balance is $",$FN($P(^PRC(442,$P(Y,U),8),U,3),"P",2) Q
51 I +RVA'<4 S RBL=$P(^PRC(442,$P(Y,U),8),U)-$P(^(8),U,3) W !,"1358 Balance is $",$FN(RBL,"P",2) Q
52 K RDA,RVA,RBL Q
Note: See TracBrowser for help on using the repository browser.