PRCHQPST ;(WASH IRMFO)/LKG-Post Init routine for RFQ install ;10/24/96 16:31
;;5.0;IFCAP;**68**;4/21/95
Q
EN N X,PRCX,DA,DIC,DIE,DLAYGO,DR,Y
S X="PRCHQ RFQ",DIC=3.8,DIC(0)="LX",DLAYGO=3.8 D ^DIC K DIC,DLAYGO
I $P(Y,U,3)=1 D
. N %,%H,%I
. S DA=+Y,DIE=3.8,DR="4////PU" D ^DIE
. S DR="5////.5" D ^DIE
. S DR="7////n" D ^DIE
. S DR="10////0" D ^DIE
. D NOW^%DTC S ^XMB(3.8,DA,2,0)="^^1^1^"_X_"^"
. S ^XMB(3.8,DA,2,1,0)="This Mail Group gets bulletins sent from vendors and filing errors."
. I $G(XPDQUES("POS001"))>0 D
. . S X=+XPDQUES("POS001")
. . Q:$D(^XMB(3.8,DA,1,"B",X))
. . S Y=DA K DA S DA(1)=Y,DIC="^XMB(3.8,DA(1),1,",DIC(0)="LX",DLAYGO=3.81
. . S DIC("P")=$P(^DD(3.8,2,0),U,2) K DD,DO D FILE^DICN K DIC,DLAYGO,DA
S X="RFQ",DIC=420.4,DIC(0)="LX",DLAYGO=420.4 D ^DIC K DIC,DLAYGO
I +Y>0 D
. S DA=+Y,DIE=420.4,PRCX="Transmit 840 - Request for Quotation"
. S DR="2///^S X=PRCX" D ^DIE
. S PRCX="PHA",DR=".7///^S X=PRCX" D ^DIE
. S DR="1////Y" D ^DIE
. S DR="3////PHA" D ^DIE
. K DA,DR,DIE
S X="TXT",DIC=420.4,DIC(0)="LX",DLAYGO=420.4 D ^DIC K DIC,DLAYGO
I +Y>0 D
. S DA=+Y,DIE=420.4,PRCX="Transmit 864 Text Message"
. S DR="2///^S X=PRCX" D ^DIE
. S PRCX="PHA",DR=".7///^S X=PRCX" D ^DIE
. S DR="1////Y" D ^DIE
. S DR="3////PHA" D ^DIE
. K DA,DR,DIE
S X="ISM-TXT",DIC=423.5,DIC(0)="LX",DLAYGO=423.5 D ^DIC K DIC,DLAYGO
I +Y>0 D
. S DA=+Y,DIE=423.5
. S PRCX="PRCHQ RFQ",DR="1///^S X=PRCX" D ^DIE
. S PRCX="IN",DR="2///^S X=PRCX" D ^DIE
. S PRCX="PRCHQ7",DR="3///^S X=PRCX" D ^DIE
. K DA,DIE,DR
S X="ISM-VQT",DIC=423.5,DIC(0)="LX",DLAYGO=423.5 D ^DIC K DIC,DLAYGO
I +Y>0 D
. S DA=+Y,DIE=423.5
. S PRCX="PRCHQ RFQ",DR="1///^S X=PRCX" D ^DIE
. S PRCX="IN",DR="2///^S X=PRCX" D ^DIE
. S PRCX="PRCHQ6",DR="3///^S X=PRCX" D ^DIE
. K DA,DIE,DR
S X="ISM-ACT",DIC=423.5,DIC(0)="LX",DLAYGO=423.5 D ^DIC K DIC,DLAYGO
I +Y>0,$P(Y,U,3)=1 D
. S DA=+Y,DIE=423.5
. S PRCX="EDP",DR="1///^S X=PRCX" D ^DIE
. S PRCX="START",DR="2///^S X=PRCX" D ^DIE
. S PRCX="PRCOACT",DR="3///^S X=PRCX" D ^DIE
. K DA,DIE,DR
;
S X="ISM-PRJ",DIC=423.5,DIC(0)="LX",DLAYGO=423.5 D ^DIC K DIC,DLAYGO
I +Y>0,$P(Y,U,3)=1 D
. S DA=+Y,DIE=423.5
. S PRCX="EDP",DR="1///^S X=PRCX" D ^DIE
. S PRCX="START",DR="2///^S X=PRCX" D ^DIE
. S PRCX="PRCOACT",DR="3///^S X=PRCX" D ^DIE
. K DA,DIE,DR
K DIC,DA
F PRCX="PRCHQ 843 UPDATE VENDOR INFO","PRCHQ 864 ERROR","PRCHQ 864 NORMAL" D
. S X=PRCX,DIC="^XMB(3.6,",DIC(0)="X" D ^DIC K DIC
. Q:+Y<1
. S DA(1)=+Y,DIC="^XMB(3.6,DA(1),2,",DIC(0)="LX",DLAYGO=3.62
. S DIC("P")=$P(^DD(3.6,4,0),U,2),X="PRCHQ RFQ" D ^DIC K DA,DIC,DLAYGO
S X="PRCOEDI ACKNOWLEDGE",DIC="^XMB(3.6,",DIC(0)="X" D ^DIC K DIC
I +Y>0 D
. S DA(1)=+Y,DIC="^XMB(3.6,DA(1),2,",DIC(0)="LX",DLAYGO=3.62
. S DIC("P")=$P(^DD(3.6,4,0),U,2),X="EDP" D ^DIC K DA,DIC,DLAYGO
IND L +^PRC(440) N DIK S DIK="^PRC(440,",DIK(1)="18.3^DB" D ENALL^DIK K DIK L -^PRC(440)
OPT ;Add options to menu
K DA S DA(1)=$O(^DIC(19,"B","PRCHQ REPORTS",""))
I DA(1)]"" D
. K DIC,DIE,DR N PRCI,PRCX,X,Y
. F PRCI=1:1:3 D
. . S PRCX=$P("PRCHPC VEN EDIT~10^PRCHPC ITEM EDIT~11^PRCHPC PO EDIT~12","^",PRCI)
. . S X=$P(PRCX,"~"),PRCX=$P(PRCX,"~",2),X=$O(^DIC(19,"B",X,"")) Q:X=""
. . Q:$D(^DIC(19,DA(1),10,"B",X)) K DD,DO
. . S DIC="^DIC(19,DA(1),10,",DIC(0)="LX",DIC("P")=$P(^DD(19,10,0),U,2)
. . D FILE^DICN K DIC
. . I Y>0 D
. . . S DA=+Y,DIE="^DIC(19,DA(1),10,",DR="3///^S X=PRCX" D ^DIE K DIE,DR
K DA S DA(1)=$O(^DIC(19,"B","PRCHUSER PA",""))
I DA(1)]"" D
. K DIC,DIE,DR
. S X=$O(^DIC(19,"B","PRCHQM","")) Q:X=""
. Q:$D(^DIC(19,DA(1),10,"B",X)) K DD,DO
. S DIC="^DIC(19,DA(1),10,",DIC(0)="LX",DIC("P")=$P(^DD(19,10,0),U,2)
. D FILE^DICN K DIC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQPST 3761 printed Sep 23, 2025@19:46:03 Page 2
PRCHQPST ;(WASH IRMFO)/LKG-Post Init routine for RFQ install ;10/24/96 16:31
+1 ;;5.0;IFCAP;**68**;4/21/95
+2 QUIT
EN NEW X,PRCX,DA,DIC,DIE,DLAYGO,DR,Y
+1 SET X="PRCHQ RFQ"
SET DIC=3.8
SET DIC(0)="LX"
SET DLAYGO=3.8
DO ^DIC
KILL DIC,DLAYGO
+2 IF $PIECE(Y,U,3)=1
Begin DoDot:1
+3 NEW %,%H,%I
+4 SET DA=+Y
SET DIE=3.8
SET DR="4////PU"
DO ^DIE
+5 SET DR="5////.5"
DO ^DIE
+6 SET DR="7////n"
DO ^DIE
+7 SET DR="10////0"
DO ^DIE
+8 DO NOW^%DTC
SET ^XMB(3.8,DA,2,0)="^^1^1^"_X_"^"
+9 SET ^XMB(3.8,DA,2,1,0)="This Mail Group gets bulletins sent from vendors and filing errors."
+10 IF $GET(XPDQUES("POS001"))>0
Begin DoDot:2
+11 SET X=+XPDQUES("POS001")
+12 if $DATA(^XMB(3.8,DA,1,"B",X))
QUIT
+13 SET Y=DA
KILL DA
SET DA(1)=Y
SET DIC="^XMB(3.8,DA(1),1,"
SET DIC(0)="LX"
SET DLAYGO=3.81
+14 SET DIC("P")=$PIECE(^DD(3.8,2,0),U,2)
KILL DD,DO
DO FILE^DICN
KILL DIC,DLAYGO,DA
End DoDot:2
End DoDot:1
+15 SET X="RFQ"
SET DIC=420.4
SET DIC(0)="LX"
SET DLAYGO=420.4
DO ^DIC
KILL DIC,DLAYGO
+16 IF +Y>0
Begin DoDot:1
+17 SET DA=+Y
SET DIE=420.4
SET PRCX="Transmit 840 - Request for Quotation"
+18 SET DR="2///^S X=PRCX"
DO ^DIE
+19 SET PRCX="PHA"
SET DR=".7///^S X=PRCX"
DO ^DIE
+20 SET DR="1////Y"
DO ^DIE
+21 SET DR="3////PHA"
DO ^DIE
+22 KILL DA,DR,DIE
End DoDot:1
+23 SET X="TXT"
SET DIC=420.4
SET DIC(0)="LX"
SET DLAYGO=420.4
DO ^DIC
KILL DIC,DLAYGO
+24 IF +Y>0
Begin DoDot:1
+25 SET DA=+Y
SET DIE=420.4
SET PRCX="Transmit 864 Text Message"
+26 SET DR="2///^S X=PRCX"
DO ^DIE
+27 SET PRCX="PHA"
SET DR=".7///^S X=PRCX"
DO ^DIE
+28 SET DR="1////Y"
DO ^DIE
+29 SET DR="3////PHA"
DO ^DIE
+30 KILL DA,DR,DIE
End DoDot:1
+31 SET X="ISM-TXT"
SET DIC=423.5
SET DIC(0)="LX"
SET DLAYGO=423.5
DO ^DIC
KILL DIC,DLAYGO
+32 IF +Y>0
Begin DoDot:1
+33 SET DA=+Y
SET DIE=423.5
+34 SET PRCX="PRCHQ RFQ"
SET DR="1///^S X=PRCX"
DO ^DIE
+35 SET PRCX="IN"
SET DR="2///^S X=PRCX"
DO ^DIE
+36 SET PRCX="PRCHQ7"
SET DR="3///^S X=PRCX"
DO ^DIE
+37 KILL DA,DIE,DR
End DoDot:1
+38 SET X="ISM-VQT"
SET DIC=423.5
SET DIC(0)="LX"
SET DLAYGO=423.5
DO ^DIC
KILL DIC,DLAYGO
+39 IF +Y>0
Begin DoDot:1
+40 SET DA=+Y
SET DIE=423.5
+41 SET PRCX="PRCHQ RFQ"
SET DR="1///^S X=PRCX"
DO ^DIE
+42 SET PRCX="IN"
SET DR="2///^S X=PRCX"
DO ^DIE
+43 SET PRCX="PRCHQ6"
SET DR="3///^S X=PRCX"
DO ^DIE
+44 KILL DA,DIE,DR
End DoDot:1
+45 SET X="ISM-ACT"
SET DIC=423.5
SET DIC(0)="LX"
SET DLAYGO=423.5
DO ^DIC
KILL DIC,DLAYGO
+46 IF +Y>0
IF $PIECE(Y,U,3)=1
Begin DoDot:1
+47 SET DA=+Y
SET DIE=423.5
+48 SET PRCX="EDP"
SET DR="1///^S X=PRCX"
DO ^DIE
+49 SET PRCX="START"
SET DR="2///^S X=PRCX"
DO ^DIE
+50 SET PRCX="PRCOACT"
SET DR="3///^S X=PRCX"
DO ^DIE
+51 KILL DA,DIE,DR
End DoDot:1
+52 ;
+53 SET X="ISM-PRJ"
SET DIC=423.5
SET DIC(0)="LX"
SET DLAYGO=423.5
DO ^DIC
KILL DIC,DLAYGO
+54 IF +Y>0
IF $PIECE(Y,U,3)=1
Begin DoDot:1
+55 SET DA=+Y
SET DIE=423.5
+56 SET PRCX="EDP"
SET DR="1///^S X=PRCX"
DO ^DIE
+57 SET PRCX="START"
SET DR="2///^S X=PRCX"
DO ^DIE
+58 SET PRCX="PRCOACT"
SET DR="3///^S X=PRCX"
DO ^DIE
+59 KILL DA,DIE,DR
End DoDot:1
+60 KILL DIC,DA
+61 FOR PRCX="PRCHQ 843 UPDATE VENDOR INFO","PRCHQ 864 ERROR","PRCHQ 864 NORMAL"
Begin DoDot:1
+62 SET X=PRCX
SET DIC="^XMB(3.6,"
SET DIC(0)="X"
DO ^DIC
KILL DIC
+63 if +Y<1
QUIT
+64 SET DA(1)=+Y
SET DIC="^XMB(3.6,DA(1),2,"
SET DIC(0)="LX"
SET DLAYGO=3.62
+65 SET DIC("P")=$PIECE(^DD(3.6,4,0),U,2)
SET X="PRCHQ RFQ"
DO ^DIC
KILL DA,DIC,DLAYGO
End DoDot:1
+66 SET X="PRCOEDI ACKNOWLEDGE"
SET DIC="^XMB(3.6,"
SET DIC(0)="X"
DO ^DIC
KILL DIC
+67 IF +Y>0
Begin DoDot:1
+68 SET DA(1)=+Y
SET DIC="^XMB(3.6,DA(1),2,"
SET DIC(0)="LX"
SET DLAYGO=3.62
+69 SET DIC("P")=$PIECE(^DD(3.6,4,0),U,2)
SET X="EDP"
DO ^DIC
KILL DA,DIC,DLAYGO
End DoDot:1
IND LOCK +^PRC(440)
NEW DIK
SET DIK="^PRC(440,"
SET DIK(1)="18.3^DB"
DO ENALL^DIK
KILL DIK
LOCK -^PRC(440)
OPT ;Add options to menu
+1 KILL DA
SET DA(1)=$ORDER(^DIC(19,"B","PRCHQ REPORTS",""))
+2 IF DA(1)]""
Begin DoDot:1
+3 KILL DIC,DIE,DR
NEW PRCI,PRCX,X,Y
+4 FOR PRCI=1:1:3
Begin DoDot:2
+5 SET PRCX=$PIECE("PRCHPC VEN EDIT~10^PRCHPC ITEM EDIT~11^PRCHPC PO EDIT~12","^",PRCI)
+6 SET X=$PIECE(PRCX,"~")
SET PRCX=$PIECE(PRCX,"~",2)
SET X=$ORDER(^DIC(19,"B",X,""))
if X=""
QUIT
+7 if $DATA(^DIC(19,DA(1),10,"B",X))
QUIT
KILL DD,DO
+8 SET DIC="^DIC(19,DA(1),10,"
SET DIC(0)="LX"
SET DIC("P")=$PIECE(^DD(19,10,0),U,2)
+9 DO FILE^DICN
KILL DIC
+10 IF Y>0
Begin DoDot:3
+11 SET DA=+Y
SET DIE="^DIC(19,DA(1),10,"
SET DR="3///^S X=PRCX"
DO ^DIE
KILL DIE,DR
End DoDot:3
End DoDot:2
End DoDot:1
+12 KILL DA
SET DA(1)=$ORDER(^DIC(19,"B","PRCHUSER PA",""))
+13 IF DA(1)]""
Begin DoDot:1
+14 KILL DIC,DIE,DR
+15 SET X=$ORDER(^DIC(19,"B","PRCHQM",""))
if X=""
QUIT
+16 if $DATA(^DIC(19,DA(1),10,"B",X))
QUIT
KILL DD,DO
+17 SET DIC="^DIC(19,DA(1),10,"
SET DIC(0)="LX"
SET DIC("P")=$PIECE(^DD(19,10,0),U,2)
+18 DO FILE^DICN
KILL DIC
End DoDot:1
+19 QUIT
