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)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPFQT1 4640 printed Dec 13, 2024@02:36:57 Page 2
RMPFQT1 ;DDC/KAW-QUEUE A BATCH FOR TRANSMISSION [ 05/21/99 11:38 AM ]
+1 ;;2.0;REMOTE ORDER/ENTRY SYSTEM;**15,16**;JUN 16, 1995
+2 ;;Reference to ^VA(200) supported by DBIA #10060
+3 ;;Reference to ^XMB(3.9) supported by DBIA #10113
+4 ;;Reference to ^DIC(5) supported by DBIA #10056
+5 ; input: RMPFBT,XMZ
+6 ;output: None
+7 SET RMPFMU="S.RMPFLOADMESSAGE"_$SELECT(RMPFMENU=0:"(ASPS)",1:"(PSAS)")
DOMAIN SET DM=^XMB("NETNAME")
+1 IF DM=""
if '$DATA(ZTSK)
WRITE $CHAR(7),!!,"*** NO DOMAIN ESTABLISHED IN THE KERNEL PARAMETER FILE ***"
GOTO END
BUILD SET RMPFDOM=RMPFMU_"@"_DM
SET (CZ,RMPFBJ)=0
SET ^XMB(3.9,XMZ,2,0)="^3.92A"
+1 SET X="NOW"
SET %DT="T"
DO ^%DT
SET RMPFD=Y
+2 FOR II=1:1
SET RMPFBJ=$ORDER(^RMPF(791812,RMPFBT,101,RMPFBJ))
if 'RMPFBJ
QUIT
IF $DATA(^(RMPFBJ,0))
IF $PIECE(^(0),U,3)=""
SET RMPFX=$PIECE(^(0),U,1)
DO SET
if '$DATA(^RMPF(791812,RMPFBT,0))
QUIT
+3 FOR II=3,4
SET $PIECE(^XMB(3.9,XMZ,2,0),U,II)=CZ
END KILL RMPFD,RMPFBJ,II,RMPFB,CZ,RMPFX,%DT,RMPFDOM,RMPFMU,DM,A
QUIT
SET ; input: RMPFX,RMPFBT,CZ
+1 ;output: None
+2 if '$DATA(^RMPF(791810,RMPFX,0))
QUIT
SET SX=^(0)
+3 SET RMPFSTAP=$SELECT($DATA(^RMPF(791810,RMPFX,"STA")):$PIECE(^("STA"),U,1),1:RMPFSTAP)
+4 SET X=$PIECE(SX,U,1)
SET RMPFTNM="VADDC "_RMPFSTAP_"-"_X
+5 SET RMPFTYP=$PIECE(SX,U,2)
IF 'RMPFTYP
DO SETE
QUIT
+6 IF '$DATA(^RMPF(791810.1,RMPFTYP,0))
DO SETE
QUIT
+7 SET RMPFHAT=$PIECE(^RMPF(791810.1,RMPFTYP,0),U,2)
+8 SET CZ=CZ+1
SET ^XMB(3.9,XMZ,2,CZ,0)=RMPFTNM_U_RMPFX_U_RMPFDOM_U_$PIECE(RMPFSYS,U,10)
+9 FOR I=0,1,2,10,11
SET ST=$GET(^RMPF(791810,RMPFX,I))
SET XX=""
Begin DoDot:1
+10 if '$LENGTH(ST)
QUIT
+11 FOR J=1:1:$SELECT(I=0:15,I=1:8,I=2:13,I=10:8,1:4)
SET X=$PIECE(ST,U,J)
Begin DoDot:2
+12 SET Z="S"_I_J
SET Y=$PIECE($TEXT(@Z),";;",2)
if Y=""
QUIT
XECUTE Y
QUIT
End DoDot:2
SET $PIECE(XX,U,J)=X
End DoDot:1
DO DEL
SET CZ=CZ+1
SET ^XMB(3.9,XMZ,2,CZ,0)=I_U_XX
MOD SET (RMPFY,M)=0
SET RMPFST1=4
+1 FOR I=1:1
SET RMPFY=$ORDER(^RMPF(791810,RMPFX,101,RMPFY))
if 'RMPFY
QUIT
IF $DATA(^(RMPFY,0))
Begin DoDot:1
+2 if '$DATA(^RMPF(791810,RMPFX,101,RMPFY,0))
QUIT
SET SY=^(0)
SET S=$PIECE(SY,U,18)
+3 if 'S
QUIT
if '$DATA(^RMPF(791810.2,S,0))
QUIT
SET X=$PIECE(^(0),U,2)
if X'="A"
QUIT
+4 FOR J=0,2,3,90
SET ST=$SELECT($DATA(^RMPF(791810,RMPFX,101,RMPFY,J)):^(J),1:"")
SET XX=""
IF $LENGTH(ST)
Begin DoDot:2
+5 FOR K=1:1:$SELECT(J=0:20,J=90:15,J=3:5,1:7)
SET X=$PIECE(ST,U,K)
Begin DoDot:3
+6 SET Z="M"_J_K
SET Y=$PIECE($TEXT(@Z),";;",2)
if Y=""
QUIT
XECUTE Y
End DoDot:3
SET $PIECE(XX,U,K)=X
End DoDot:2
DO DEL
SET CZ=CZ+1
SET ^XMB(3.9,XMZ,2,CZ,0)="M"_RMPFY_U_J_"^^"_XX
+7 SET RMPFZ=0
FOR KX=0:0
SET RMPFZ=$ORDER(^RMPF(791810,RMPFX,101,RMPFY,101,RMPFZ))
if 'RMPFZ
QUIT
SET S0=^(RMPFZ,0)
SET CZ=CZ+1
SET ^XMB(3.9,XMZ,2,CZ,0)="M"_RMPFY_"^101^"_"S"_RMPFZ_U_S0
+8 SET RMPFZ=0
FOR KX=0:0
SET RMPFZ=$ORDER(^RMPF(791810,RMPFX,101,RMPFY,102,RMPFZ))
if 'RMPFZ
QUIT
SET ST=^(RMPFZ,0)
Begin DoDot:2
+9 FOR K=1:1:7
SET X=$PIECE(ST,U,K)
Begin DoDot:3
+10 SET Z="C0"_K
SET Y=$PIECE($TEXT(@Z),";;",2)
if Y=""
QUIT
XECUTE Y
End DoDot:3
SET $PIECE(XX,U,K)=X
End DoDot:2
DO DEL
SET CZ=CZ+1
SET ^XMB(3.9,XMZ,2,CZ,0)="M"_RMPFY_"^102^C"_RMPFZ_U_XX
+11 IF '$DATA(TD)
SET %DT="T"
SET X="NOW"
DO ^%DT
SET TD=Y
+12 SET AC=$PIECE(SY,U,19)
if AC=""
SET AC="O"
if AC="C"&("CI"[RMPFHAT)
QUIT
+13 SET RMPFST=$ORDER(^RMPF(791810.2,"AB",AC,0))
IF RMPFST=""
SET RMPFST=4
+14 SET DIE="^RMPF(791810,"_RMPFX_",101,"
SET DA(1)=RMPFX
SET DA=RMPFY
+15 SET DR=".18///"_RMPFST_";.17////"_TD
DO ^DIE
SET RMPFST1=RMPFST
End DoDot:1
+16 IF '$DATA(TD)
SET %DT="T"
SET X="NOW"
DO ^%DT
SET TD=Y
+17 SET DIE="^RMPF(791810,"
SET DA=RMPFX
SET DR=".03////"_RMPFST1_";.06////"_TD
+18 DO ^DIE
+19 SET CZ=CZ+1
SET SZ=""
DO ^RMPFQT2
SET ^XMB(3.9,XMZ,2,CZ,0)="21^"_SZ
+20 SET CZ=CZ+1
SET ^XMB(3.9,XMZ,2,CZ,0)="22^"_XX
SETE KILL RMPFY,RMPFE,RMPFTNM,RMPFTYP,RMPFZ,RMPFHAT,RMPFST,RMPFST1,SZ,I,J,JJ,K
+1 KILL AC,D0,DA,DI,DIC,DIE,DQ,DR,L,M,ST,KX,S,%,%Y
+2 KILL X,XX,Y,YY,Z,TP,TD,TL,S1,SX,SY,X
QUIT
DEL FOR JJ=$LENGTH(XX):-1:0
if $EXTRACT(XX,JJ)'=U
QUIT
SET XX=$EXTRACT(XX,1,JJ-1)
+1 KILL JJ
QUIT
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)
