- 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 Mar 13, 2025@21:14:46 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
