source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29T.m@ 771

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

initial load of WorldVistAEHR
File size: 5.3 KB
Line 
1RMPR29T ;PHX/JLT-PROCESSING 2529-3 ACTION ;01/04/95 3:56 PM
2 ;;3.0;PROSTHETICS;**78,75**;Feb 09, 1996;Build 25
3 ;
4 ;RMS 08/25/03 Patch #78 - Add shipment date for
5 ;Billing Awareness project
6 ;SPS 06/06/06 Patch #75 - Removed shipment date
7 ;
8ASK ;ASK TYPE OF PROCESSING ACTION
9 ;CALLED BY RMPR29T
10 ;VARIABLES REQUIRED: RMPRDA - ENTRY IN FILE 664.1
11 ; RMPR ARRAY - AN ARRAY SET UP BY CALL TO
12 ; DIV4^RMPRSIT
13 ;
14 I $Y<17 F W ! Q:$Y>17
15 W !,RMPR("L") K DIR S DIR("A")="Select Processing Action",DIR("A")=$S($D(HLD):DIR("A")_" or press 'return' to view more items: ",1:DIR("A")_": ") G:$D(PSM) AMP G:$D(PASS) ASP G:$D(PAC) ACK G:$D(PNK) ANK
16 S DIR(0)="SAO^1:EDIT 2529-3 ITEM;2:PROCESS JOB SECTION ;3:INITIATE PROCUREMENT;4:PRINT 2529-3 ;5:RE-DISPLAY SCREEN ;6:CANCEL 2529-3",DIR("?")="^D HELP^RMPR29W W !,$C(7),?5,""Enter a number 1-6""" D HELP^RMPR29W
17 D ^DIR I (X=""&$D(HLD)) S PAGE=PAGE+1 D HD^RMPR29W G:$D(^UTILITY($J,"W"))!$O(^UTILITY("DIQ1",$J,664.16,+RI,7,0)) EXT^RMPR29D G ITD^RMPR29D
18 G:$D(DTOUT) END^RMPR29A G:+Y=1 ITM^RMPR29A G:+Y=2 ^RMPR29B G:+Y=3 ^RMPR29P G:+Y=5 DISP^RMPR29D G:+Y=6 CA^RMPR29C
19 I +Y=4 D PRT^RMPR29R G DISP^RMPR29D
20 I $D(^XUSEC("RMPR LAB SUPERVISOR",DUZ)) G COM
21 K DIR S DIR(0)="Y",DIR("A")="Ready for Supervisor Inspection",DIR("B")="NO" D ^DIR I +Y=1 W !!,?5,$C(7),"Request Ready Inspection" S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///^S X=""PC""" D ^DIE
22 ;I +Y=0 G END^RMPR29A
23 G END^RMPR29A
24 ; D ^RMPR4E23 ADDED BY RMS
25ASP ;ASK TYPE OF ASSIGNMENT ACTION
26 S DIR(0)="SAO^1:EDIT 2529-3 ITEM;2:ASSIGN 2529-3 TO TECH;3:CANCEL 2529-3;4:PRINT 2529-3",DIR("?")="^D HELP^RMPR29W" D HELP^RMPR29W
27 D ^DIR I (X=""&$D(HLD)) S PAGE=PAGE+1 D HD^RMPR29W G:$D(^UTILITY($J,"W"))!$O(^UTILITY("DIQ1",$J,664.16,+RI,7,0)) EXT^RMPR29D G ITD^RMPR29D
28 G:$D(DTOUT) EXIT^RMPR29S G:+Y=1 ITM^RMPR29A G:+Y=2 ATCH^RMPR29S G:+Y=3 CA^RMPR29C
29 I +Y=4 D PRT^RMPR29R G DISP^RMPR29D
30 G EXIT^RMPR29S
31ACK ;ASK TYPE OF COMPLETION ACTION
32 S DIR(0)="SAO^1:EDIT 2529-3 ITEM ;2:COMPLETE JOB SECTION;3:RETURN 2529-3 TO LAB;4:PRINT 2529-3 ;5:RE-DISPLAY SCREEN ;6:CANCEL 2529-3",DIR("?")="^D HELP^RMPR29W W !,$C(7),?5,""Enter a Number 1-6""" D HELP^RMPR29W
33 D ^DIR I (X=""&$D(HLD)) S PAGE=PAGE+1 D HD^RMPR29W G:$D(^UTILITY($J,"W"))!($O(^UTILITY("DIQ1",$J,664.16,+RI,7,0))) EXT^RMPR29D G ITD^RMPR29D
34 G:$D(DTOUT) END^RMPR29A G:+Y=1 ITM^RMPR29A G:+Y=2 ^RMPR29B G:+Y=3 RT^RMPR29C G:+Y=5 DISP^RMPR29D G:+Y=6 CA^RMPR29C
35 I +Y=4 D PRT^RMPR29R G DISP^RMPR29D
36COM ;COMPLETE 2529-3
37 K DIR S DIR(0)="Y",DIR("A")="Complete and Post 2529-3",DIR("B")="NO" D ^DIR I +Y=0 G END^RMPR29A
38 D CHK I $D(RFL) G END^RMPR29A
39 K DA,Y,DIC,X S DA=RMPRDA,DR="24",DIE="^RMPR(664.1," D ^DIE I $D(DTOUT)!($D(Y)) D MESS G END^RMPR29A
40 I $P(^RMPR(664.1,RMPRDA,0),U,27)=3 W !!,$C(7),?5,"2529-3 cannot be completed until issued to Veteran" G END^RMPR29A
41 S DA=RMPRDA,DR="33;20R",DIE="^RMPR(664.1," D ^DIE I $D(DTOUT)!($D(Y)) D MESS G END^RMPR29A
42 S:'$P(^RMPR(664.1,RMPRDA,0),U,25) $P(^RMPR(664.1,RMPRDA,0),U,25)=DUZ S $P(^RMPR(664.1,RMPRDA,0),U,26)=DT
43 W !!,?5,$C(7),"Request Completed and Posted!!!" S DIE="^RMPR(664.1,",DR="16///^S X=""C""",DA=RMPRDA D ^DIE
44 G END^RMPR29A
45ANK ;ASK TYPE OF CLOSE OUT ACTION
46 S DIR(0)="SAO^1:EDIT 2529-3 ITEM ;2:PRINT 2529-3 ;3:RE-DISPLAY SCREEN ;4:CANCEL 2529-3 ;5:CLOSE OUT A 2529-3",DIR("?")="^D HELP^RMPR29W W !,$C(7),?5,""Enter a Number 1-5""" D HELP^RMPR29W
47 D ^DIR I (X=""&$D(HLD)) S PAGE=PAGE+1 D HDC^RMPR29W G:$D(^UTILITY($J,"W"))!($O(^UTILITY("DIQ1",$J,664.16,+RI,7,0))) EXT^RMPR29D G ITD^RMPR29D
48 G:+Y=1 ITM^RMPR29A G:+Y=3 DISP^RMPR29D G:+Y=4 CA^RMPR29C
49 I +Y=2 D PRT^RMPR29R G DISP^RMPR29D
50 ;K DIR S DIR(0)="Y",DIR("A")="Close out 2529-3",DIR("B")="NO" D ^DIR I +Y=0 D MESS G EXIT^RMPR29C
51 I +Y=5 D G EXIT^RMPR29C
52 .K DA,Y,DIC,X
53 .S DA=RMPRDA,DIE="^RMPR(664.1,",DR="4;33;20R"
54 .D ^DIE
55 .I $D(DTOUT)!$D(Y) D MESS Q
56 .W !!,?5,$C(7),"Request Closed out and Posted!!!"
57 .I $P(^RMPR(664.1,RMPRDA,0),U,20),$P(^(0),U,23) D DEL^RMPR29P(RMPRDA),PST^RMPR29P(RMPRDA)
58 .N RMPRDL S RMPRDL=$P($G(^RMPR(664.1,RMPRDA,7)),U,2)
59 .F RI=0:0 S RI=$O(^RMPR(664.1,RMPRDA,2,RI)) Q:RI'>0 I $D(^(RI,0)) S DA=$P(^(0),U,5) I +DA>0,RMPRDL S DIE="^RMPR(660,",DR="10///@;10///^S X=RMPRDL" D ^DIE
60 .S:'$P(^RMPR(664.1,RMPRDA,0),U,25) $P(^RMPR(664.1,RMPRDA,0),U,25)=DUZ S $P(^RMPR(664.1,RMPRDA,0),U,26)=DT
61 .S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///^S X=""C""" D ^DIE
62 Q
63CHK ;CHK TO SEE IF JOB SECTION IS COMPLETE
64 K RFL F RI=0:0 S RI=$O(^RMPR(664.1,RMPRDA,2,RI)) Q:RI'>0 I $D(^(RI,0)) S RDA=^(0),RA=$P(RDA,U,5) D
65 .;see internal notes
66 .S (RZP,DA)=$O(^RMPR(664.2,"C",RA,0))
67 .S RMPRCD=$P($G(^RMPR(664.2,+DA,0)),U,10) I 'RMPRCD S RFL=1 W !!,$C(7),"Date Completed has not been entered for JOB "
68 I $D(RFL) W !!,$C(7),?5,"2529-3 Job Section is Incomplete!!"
69 Q
70AMP ;ASK TYPE OF MULTIPLE ASSIGMENT ACTION
71 S DIR(0)="SAO^1:EDIT 2529-3 ITEM;2:ASSIGN 2529-3 TO TECH;3:CANCEL 2529-3;4:PRINT 2529-3 ;5:NEXT ENTRY ;6:PREVIOUS ENTRY",DIR("?")="^D HELP^RMPR29W" D HELP^RMPR29W
72 D ^DIR I (X=""&$D(HLD)) S PAGE=PAGE+1 D HD^RMPR29W G:$D(^UTILITY($J,"W"))!$O(^UTILITY("DIQ1",$J,664.16,+RI,7,0)) EXT^RMPR29D G ITD^RMPR29D
73 G:$D(DTOUT) EXIT^RMPR29S G:+Y=1 ITM^RMPR29A G:+Y=2 ATCH^RMPR29S G:+Y=3 CA^RMPR29C G:+Y=5 NEXT^RMPR29S G:+Y=6 PREV^RMPR29S
74 I +Y=4 D PRT^RMPR29R G DISP^RMPR29D
75 G EXIT^RMPR29S
76MESS ;MESSAGE IF DTOUT OR $D(Y)
77 W !!,$C(7),?5,"2529-3 has not been completed!!" Q
78 Q
Note: See TracBrowser for help on using the repository browser.