source: FOIAVistA/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFQM1.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: 3.4 KB
Line 
1RMPFQM1 ;DDC/KAW-CONTINUATION OF RMPFQM [ 03/27/98 2:00 PM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**8,10,16**;MAY 30, 1995
3LOAD S SX=XMRG,NM=$P(SX,U,1) S ST="" F IK=1:1:78 S ST=ST_" "
4 Q:NM'?3N.E7N.E K RMPFX D Q:'$D(RMPFX)
5 .S RMPFX=$P(SX,U,2) I 'RMPFX K RMPFX Q
6 .I '$D(^RMPF(791810,RMPFX,0)) K RMPFX Q
7 .I '$D(^RMPF(791810,RMPFX,201,0)) S ^RMPF(791810,RMPFX,201,0)="^791810.0201"
8 .S X="NOW",%DT="T" D ^%DT S TD=Y
9 .S DIC="^RMPF(791810,"_RMPFX_",201,",DIC(0)="L",DLAYGO=791810
10 .S X=MD,DA(1)=RMPFX K DD,DO D FILE^DICN I Y=-1 K RMPFX Q
11 .S FY=+Y,$P(^RMPF(791810,RMPFX,201,FY,0),U,2)=XMZ
12 .D BLANK
13 .S SM=^RMPF(791810,RMPFX,0),X=$P(SM,U,2)
14 .I X,$D(^RMPF(791810.1,X,0)) S RMPFTYP=$E(($P(^(0),U,8)_" "),1,6),RMPFHAT=$P(^(0),U,2)
15 .S X=$P(SM,U,4) I X S DFN=X D DEM^VADPT S Y=$E($P(VADM(2),U,1),1,15),RMPFNAM=$E(($P(VADM(1),U,1)_" "),1,15)_"-"_$E((Y_" "),6,9)
16LINEI F IX=1:1 X XMREC Q:XMER=-1 S SX=XMRG,X=$P(SX,U,1) D Q:'$D(RMPFX)
17 .I X?3N.E D:X=301 AUTH S XMPOS=XMPOS-1 K RMPFX Q
18 .I '$D(^RMPF(791810,RMPFX,201,FY,101,0)) S ^RMPF(791810,RMPFX,201,FY,101,0)="^791810.201101^^"
19 .S DIC="^RMPF(791810,"_RMPFX_",201,"_FY_",101,",DA(2)=RMPFX
20 .S DA(1)=FY,DIC(0)="L",DLAYGO=791810,X=$P(SX,U,1)
21 .K DD,DO D FILE^DICN
22 .Q:Y=-1
23 .S X=$P(SX,U,9) I X'="" S $P(^RMPF(791810,RMPFX,0),U,7)=X,^RMPF(791810,"D",X,RMPFX)=""
24 .S $P(^RMPF(791810,RMPFX,201,FY,101,+Y,0),U,2,99)=$P(SX,U,2,99),$P(^(0),U,7)=""
25 .S X=$P(SX,U,1) I X["STATUS COMPLETE"!(X["ORDER PLACED")!(X["CANCELED")!(X["CERTIFICATION PROCESSED") S $P(^RMPF(791810,RMPFX,201,FY,101,+Y,0),U,6)=1
26 .S RMPFST=$P(SX,U,4),RMPFY=$P(SX,U,8)
27 .I RMPFY,RMPFHAT="I",$P($G(^RMPF(791810,RMPFX,101,RMPFY,90)),U,10),$P(^(0),U,8) S RMPFST=$O(^RMPF(791810.2,"B","COMPLETE",0))
28 .I RMPFST D
29 ..I $D(^RMPF(791810.2,RMPFST,0)) S RMPFSTP=$E(($P(^(0),U,4)_" "),1,6)
30 ..S Y=$P(SX,U,10)
31 ..I Y?7N S RMPFSB=$E(Y,4,5)_"-"_$E(Y,6,7)_"-"_($E(Y,1,3)+1700)
32 ..I RMPFY S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY,DR=".18////"_RMPFST_";.17////"_TD S:RMPFST=11 DR=DR_";.15////C" D ^DIE
33 ..I RMPFST=6!(RMPFST=10),'RMPFY S DA=0 F S DA=$O(^RMPF(791810,RMPFX,101,DA)) Q:'DA S DIE="^RMPF(791810,"_RMPFX_",101,",DR=".18////"_RMPFST_";.2////1" D ^DIE
34 ..I RMPFST=6!(RMPFST=10) D REMOV^RMPFET10
35 ..I RMPFST=17,RMPFHAT="C" S DIE="^RMPF(791810,",DA=RMPFX,DR=".02////5" D ^DIE
36 ..S SC=$P($G(^RMPF(791810.2,RMPFST,0)),U,5) S:SC="" SC="E"
37 ..I SC="E" D SETORD Q
38 ..D ARRAY^RMPFDT2 S (E,P,X)=0
39 ..F S X=$O(RMPFO(X)) Q:'X D
40 ...S Y=RMPFO(X) Q:'Y Q:'$D(^RMPF(791810.2,Y,0)) S SC=$P(^(0),U,5) Q:SC=""
41 ...I SC="E" S E=Y Q
42 ...I SC="P" S P=Y
43 ..I E>0 S RMPFST=E D SETORD Q
44 ..I P>0 S RMPFST=P
45 ..D SETORD
46 .I $D(RMPFY),RMPFY,$D(^RMPF(791810,RMPFX,101,RMPFY,0)) S S0=^(0) D
47 ..S IT=$P(S0,U,1) Q:'IT
48 ..I IT=1 S RMPFITP=$P($G(^RMPF(791810,RMPFX,101,RMPFY,2)),U,2)
49 ..E S RMPFITP=$P($G(^RMPF(791811,IT,0)),U,1)
50 ..S RMPFITP=$E(RMPFITP_" ",1,30)
51 .S CT=CT+1,XQSTXT(CT)=RMPFNAM_" "_RMPFTYP_" "_RMPFSTP_" "_RMPFITP_" "_RMPFSB
52 .D BLANK Q
53 Q
54AUTH K ^RMPF(791810,RMPFX,301)
55 S ^RMPF(791810,RMPFX,301,0)="^791810.0301",CY=1,XMPOS=XMPOS-1
56 F IY=1:1 X XMREC Q:XMER=-1 S X=$P(XMRG,U,1),SX=$P(XMRG,U,2,99) D Q:X'=301
57 .I X'=301 S XMPOS=XMPOS-1 Q
58 .S ^RMPF(791810,RMPFX,301,CY,0)=SX
59 .S ^RMPF(791810,RMPFX,301,"B",$P(SX,U,1),CY)="",CY=CY+1
60 Q
61SETORD S DIE="^RMPF(791810,",DA=RMPFX,DR=".03////"_RMPFST D ^DIE Q
62BLANK S RMPFNAM=" "
63 S (RMPFSTP,RMPFTYP)=" "
64 S RMPFITP=" "
65 S RMPFSB=" "
66 Q
Note: See TracBrowser for help on using the repository browser.