source: WorldVistAEHR/trunk/r/REMOTE_ORDER_ENTRY_SYSTEM-RMPF-RMPJ/RMPFQT1.m@ 1042

RMPFQT1 ;DDC/KAW-QUEUE A BATCH FOR TRANSMISSION [ 05/21/99  11:38 AM ]
 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**15,16**;JUN 16, 1995
 ;;Reference to ^VA(200) supported by DBIA #10060
 ;;Reference to ^XMB(3.9) supported by DBIA #10113
 ;;Reference to ^DIC(5) supported by DBIA #10056
 ; input: RMPFBT,XMZ
 ;output: None
 S RMPFMU="S.RMPFLOADMESSAGE"_$S(RMPFMENU=0:"(ASPS)",1:"(PSAS)")
DOMAIN S DM=^XMB("NETNAME")
 I DM="" W:'$D(ZTSK) $C(7),!!,"*** NO DOMAIN ESTABLISHED IN THE KERNEL PARAMETER FILE ***" G END
BUILD S RMPFDOM=RMPFMU_"@"_DM,(CZ,RMPFBJ)=0,^XMB(3.9,XMZ,2,0)="^3.92A"
 S X="NOW",%DT="T" D ^%DT S RMPFD=Y
 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))
 F II=3,4 S $P(^XMB(3.9,XMZ,2,0),U,II)=CZ
END K RMPFD,RMPFBJ,II,RMPFB,CZ,RMPFX,%DT,RMPFDOM,RMPFMU,DM,A Q
SET ; input: RMPFX,RMPFBT,CZ
 ;output: None
 Q:'$D(^RMPF(791810,RMPFX,0))  S SX=^(0)
 S RMPFSTAP=$S($D(^RMPF(791810,RMPFX,"STA")):$P(^("STA"),U,1),1:RMPFSTAP)
 S X=$P(SX,U,1),RMPFTNM="VADDC "_RMPFSTAP_"-"_X
 S RMPFTYP=$P(SX,U,2) I 'RMPFTYP D SETE Q
 I '$D(^RMPF(791810.1,RMPFTYP,0)) D SETE Q
 S RMPFHAT=$P(^RMPF(791810.1,RMPFTYP,0),U,2)
 S CZ=CZ+1,^XMB(3.9,XMZ,2,CZ,0)=RMPFTNM_U_RMPFX_U_RMPFDOM_U_$P(RMPFSYS,U,10)
 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
 .Q:'$L(ST)
 .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
 ..S Z="S"_I_J,Y=$P($T(@Z),";;",2) Q:Y=""  X Y Q
MOD S (RMPFY,M)=0,RMPFST1=4
 F I=1:1 S RMPFY=$O(^RMPF(791810,RMPFX,101,RMPFY)) Q:'RMPFY  I $D(^(RMPFY,0)) D
 .Q:'$D(^RMPF(791810,RMPFX,101,RMPFY,0))  S SY=^(0),S=$P(SY,U,18)
 .Q:'S  Q:'$D(^RMPF(791810.2,S,0))  S X=$P(^(0),U,2) Q:X'="A"
 .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
 ..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
 ...S Z="M"_J_K,Y=$P($T(@Z),";;",2) Q:Y=""  X Y
 .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
 .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
 ..F K=1:1:7 S X=$P(ST,U,K) D  S $P(XX,U,K)=X
 ...S Z="C0"_K,Y=$P($T(@Z),";;",2) Q:Y=""  X Y
 .I '$D(TD) S %DT="T",X="NOW" D ^%DT S TD=Y
 .S AC=$P(SY,U,19) S:AC="" AC="O" Q:AC="C"&("CI"[RMPFHAT)
 .S RMPFST=$O(^RMPF(791810.2,"AB",AC,0)) I RMPFST="" S RMPFST=4
 .S DIE="^RMPF(791810,"_RMPFX_",101,",DA(1)=RMPFX,DA=RMPFY
 .S DR=".18///"_RMPFST_";.17////"_TD D ^DIE S RMPFST1=RMPFST
 I '$D(TD) S %DT="T",X="NOW" D ^%DT S TD=Y
 S DIE="^RMPF(791810,",DA=RMPFX,DR=".03////"_RMPFST1_";.06////"_TD
 D ^DIE
 S CZ=CZ+1,SZ="" D ^RMPFQT2 S ^XMB(3.9,XMZ,2,CZ,0)="21^"_SZ
 S CZ=CZ+1,^XMB(3.9,XMZ,2,CZ,0)="22^"_XX
SETE K RMPFY,RMPFE,RMPFTNM,RMPFTYP,RMPFZ,RMPFHAT,RMPFST,RMPFST1,SZ,I,J,JJ,K
 K AC,D0,DA,DI,DIC,DIE,DQ,DR,L,M,ST,KX,S,%,%Y
 K X,XX,Y,YY,Z,TP,TD,TL,S1,SX,SY,X Q
DEL F JJ=$L(XX):-1:0 Q:$E(XX,JJ)'=U  S XX=$E(XX,1,JJ-1)
 K JJ Q
S04 ;;Q:'X  N I,J S DFN=X D DEM^VADPT S X=$P(VADM(1),U,1) K VADM,DFN
S05 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
S08 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
S010 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
S012 ;;I X,$D(^RMPF(791812,X,0)) S X=$P(^(0),U,1)
S106 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
S15 ;;I X,$D(^DIC(5,X,0)) S X=$P(^(0),U,2)
S21 ;;I X,$D(^RMPR(662,X,0)) S X=$P(^(0),U,1)
S22 ;;I X,$D(^RMPF(791810.4,X,0)) S X=$P(^(0),U,1)
S23 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
S26 ;;I X,$D(^RMPF(791810.4,X,0)) S X=$P(^(0),U,1)
S27 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
M01 ;;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
M02 ;;I X,$D(^RMPF(791811.3,X,0)) S X=$P(^(0),U,1)
M018 ;;I X,$D(^RMPF(791810.2,X,0)) S X=$P(^(0),U,1)
M23 ;;I X,$D(^RMPF(791811.3,X,0)) S X=$P(^(0),U,1)
M24 ;;I X,$D(^RMPF(791811.1,X,0)) S X=$P(^(0),U,1)
M26 ;;I X S X=$P($G(^RMPF(791811.4,X,0)),U,2)
M32 ;;I X S X=$P($G(^RMPR(662,X,0)),U,1)
M901 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
M908 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
M9010 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
M9012 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
M9013 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)
M9014 ;;I X,$D(^RMPF(791810.6,X,0)) S X=$P(^(0),U,1)
C01 ;;I X,$D(^RMPF(791811.2,X,0)) S X=$P(^(0),U,3)
C05 ;;I X,$D(^VA(200,X,0)) S X=$P(^(0),U,1)