source: FOIAVistA/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFQT1.m@ 761

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

initial load of FOIAVistA 6/30/08 version

File size: 4.5 KB
Line 
1RMPFQT1 ;DDC/KAW-QUEUE A BATCH FOR TRANSMISSION [ 05/21/99 11:38 AM ]
2 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**15,16**;JUN 16, 1995
3 ;;Reference to ^VA(200) supported by DBIA #10060
4 ;;Reference to ^XMB(3.9) supported by DBIA #10113
5 ;;Reference to ^DIC(5) supported by DBIA #10056
6 ; input: RMPFBT,XMZ
7 ;output: None
8 S RMPFMU="S.RMPFLOADMESSAGE"_$S(RMPFMENU=0:"(ASPS)",1:"(PSAS)")
9DOMAIN S DM=^XMB("NETNAME")
10 I DM="" W:'$D(ZTSK) $C(7),!!,"*** NO DOMAIN ESTABLISHED IN THE KERNEL PARAMETER FILE ***" G END
11BUILD S RMPFDOM=RMPFMU_"@"_DM,(CZ,RMPFBJ)=0,^XMB(3.9,XMZ,2,0)="^3.92A"
12 S X="NOW",%DT="T" D ^%DT S RMPFD=Y
13 F II=1:1 S RMPFBJ=$O(^RMPF(791812,RMPFBT,101,RMPFBJ)) Q:'RMPFBJ I $D(^(RMPFBJ,0)),$P(^(0),U,3)="" S RMPFX=$P(^(0),U,1) D SET Q:'$D(^RMPF(791812,RMPFBT,0))
14 F II=3,4 S $P(^XMB(3.9,XMZ,2,0),U,II)=CZ
15END K RMPFD,RMPFBJ,II,RMPFB,CZ,RMPFX,%DT,RMPFDOM,RMPFMU,DM,A Q
16SET ; input: RMPFX,RMPFBT,CZ
17 ;output: None
18 Q:'$D(^RMPF(791810,RMPFX,0)) S SX=^(0)
19 S RMPFSTAP=$S($D(^RMPF(791810,RMPFX,"STA")):$P(^("STA"),U,1),1:RMPFSTAP)
20 S X=$P(SX,U,1),RMPFTNM="VADDC "_RMPFSTAP_"-"_X
21 S RMPFTYP=$P(SX,U,2) I 'RMPFTYP D SETE Q
22 I '$D(^RMPF(791810.1,RMPFTYP,0)) D SETE Q
23 S RMPFHAT=$P(^RMPF(791810.1,RMPFTYP,0),U,2)
24 S CZ=CZ+1,^XMB(3.9,XMZ,2,CZ,0)=RMPFTNM_U_RMPFX_U_RMPFDOM_U_$P(RMPFSYS,U,10)
25 F I=0,1,2,10,11 S ST=$G(^RMPF(791810,RMPFX,I)),XX="" D D DEL S CZ=CZ+1,^XMB(3.9,XMZ,2,CZ,0)=I_U_XX
26 .Q:'$L(ST)
27 .F J=1:1:$S(I=0:15,I=1:8,I=2:13,I=10:8,1:4) S X=$P(ST,U,J) D S $P(XX,U,J)=X
28 ..S Z="S"_I_J,Y=$P($T(@Z),";;",2) Q:Y="" X Y Q
29MOD S (RMPFY,M)=0,RMPFST1=4
30 F I=1:1 S RMPFY=$O(^RMPF(791810,RMPFX,101,RMPFY)) Q:'RMPFY I $D(^(RMPFY,0)) D
31 .Q:'$D(^RMPF(791810,RMPFX,101,RMPFY,0)) S SY=^(0),S=$P(SY,U,18)
32 .Q:'S Q:'$D(^RMPF(791810.2,S,0)) S X=$P(^(0),U,2) Q:X'="A"
33 .F J=0,2,3,90 S ST=$S($D(^RMPF(791810,RMPFX,101,RMPFY,J)):^(J),1:""),XX="" I $L(ST) D D DEL S CZ=CZ+1,^XMB(3.9,XMZ,2,CZ,0)="M"_RMPFY_U_J_"^^"_XX
34 ..F K=1:1:$S(J=0:20,J=90:15,J=3:5,1:7) S X=$P(ST,U,K) D S $P(XX,U,K)=X
35 ...S Z="M"_J_K,Y=$P($T(@Z),";;",2) Q:Y="" X Y
36 .S RMPFZ=0 F KX=0:0 S RMPFZ=$O(^RMPF(791810,RMPFX,101,RMPFY,101,RMPFZ)) Q:'RMPFZ S S0=^(RMPFZ,0),CZ=CZ+1,^XMB(3.9,XMZ,2,CZ,0)="M"_RMPFY_"^101^"_"S"_RMPFZ_U_S0
37 .S RMPFZ=0 F KX=0:0 S RMPFZ=$O(^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ)) Q:'RMPFZ S ST=^(RMPFZ,0) D D DEL S CZ=CZ+1,^XMB(3.9,XMZ,2,CZ,0)="M"_RMPFY_"^102^C"_RMPFZ_U_XX
38 ..F K=1:1:7 S X=$P(ST,U,K) D S $P(XX,U,K)=X
39 ...S Z="C0"_K,Y=$P($T(@Z),";;",2) Q:Y="" X Y
40 .I '$D(TD) S %DT="T",X="NOW" D ^%DT S TD=Y
41 .S AC=$P(SY,U,19) S:AC="" AC="O" Q:AC="C"&("CI"[RMPFHAT)
42 .S RMPFST=$O(^RMPF(791810.2,"AB",AC,0)) I RMPFST="" S RMPFST=4
43 .S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY
44 .S DR=".18///"_RMPFST_";.17////"_TD D ^DIE S RMPFST1=RMPFST
45 I '$D(TD) S %DT="T",X="NOW" D ^%DT S TD=Y
46 S DIE="^RMPF(791810,",DA=RMPFX,DR=".03////"_RMPFST1_";.06////"_TD
47 D ^DIE
48 S CZ=CZ+1,SZ="" D ^RMPFQT2 S ^XMB(3.9,XMZ,2,CZ,0)="21^"_SZ
49 S CZ=CZ+1,^XMB(3.9,XMZ,2,CZ,0)="22^"_XX
50SETE K RMPFY,RMPFE,RMPFTNM,RMPFTYP,RMPFZ,RMPFHAT,RMPFST,RMPFST1,SZ,I,J,JJ,K
51 K AC,D0,DA,DI,DIC,DIE,DQ,DR,L,M,ST,KX,S,%,%Y
52 K X,XX,Y,YY,Z,TP,TD,TL,S1,SX,SY,X Q
53DEL F JJ=$L(XX):-1:0 Q:$E(XX,JJ)'=U S XX=$E(XX,1,JJ-1)
54 K JJ Q
55S04 ;;Q:'X N I,J S DFN=X D DEM^VADPT S X=$P(VADM(1),U,1) K VADM,DFN
56S05 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
57S08 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
58S010 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
59S012 ;;I X,$D(^RMPF(791812,X,0)) S X=$P(^(0),U,1)
60S106 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
61S15 ;;I X,$D(^DIC(5,X,0)) S X=$P(^(0),U,2)
62S21 ;;I X,$D(^RMPR(662,X,0)) S X=$P(^(0),U,1)
63S22 ;;I X,$D(^RMPF(791810.4,X,0)) S X=$P(^(0),U,1)
64S23 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
65S26 ;;I X,$D(^RMPF(791810.4,X,0)) S X=$P(^(0),U,1)
66S27 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
67M01 ;;I X,$D(^RMPF(791811,X,0)) S Y=X,X=$P(^(0),U,1),YY=$P(^(0),U,2) I X'="NON-CONTRACT" S $P(^RMPF(791810,RMPFX,101,RMPFY,2),U,1)=YY
68M02 ;;I X,$D(^RMPF(791811.3,X,0)) S X=$P(^(0),U,1)
69M018 ;;I X,$D(^RMPF(791810.2,X,0)) S X=$P(^(0),U,1)
70M23 ;;I X,$D(^RMPF(791811.3,X,0)) S X=$P(^(0),U,1)
71M24 ;;I X,$D(^RMPF(791811.1,X,0)) S X=$P(^(0),U,1)
72M26 ;;I X S X=$P($G(^RMPF(791811.4,X,0)),U,2)
73M32 ;;I X S X=$P($G(^RMPR(662,X,0)),U,1)
74M901 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
75M908 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
76M9010 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
77M9012 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
78M9013 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
79M9014 ;;I X,$D(^RMPF(791810.6,X,0)) S X=$P(^(0),U,1)
80C01 ;;I X,$D(^RMPF(791811.2,X,0)) S X=$P(^(0),U,3)
81C05 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
Note: See TracBrowser for help on using the repository browser.