RMPFQT1.m

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 ---RMPFQT1   4640     printed  Mar 13, 2025@21:42:03                                                                                                                                                                                                     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)